packages feed

data-flags 0.0.2 → 0.0.3

raw patch · 2 files changed

+50/−14 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Data.Flags.TH: enumADT :: String -> Name -> [(String, Integer)] -> Q [Dec]
- Data.Flags: (.*.) :: (Flags a) => a -> a -> a
+ Data.Flags: (.*.) :: Flags a => a -> a -> a
- Data.Flags: (.+.) :: (Flags a) => a -> a -> a
+ Data.Flags: (.+.) :: Flags a => a -> a -> a
- Data.Flags: (.-.) :: (Flags a) => a -> a -> a
+ Data.Flags: (.-.) :: Flags a => a -> a -> a
- Data.Flags: (./~.) :: (Flags a) => a -> a -> Bool
+ Data.Flags: (./~.) :: Flags a => a -> a -> Bool
- Data.Flags: (.<=.) :: (Flags a) => a -> a -> Bool
+ Data.Flags: (.<=.) :: Flags a => a -> a -> Bool
- Data.Flags: (.>=.) :: (Flags a) => a -> a -> Bool
+ Data.Flags: (.>=.) :: Flags a => a -> a -> Bool
- Data.Flags: (.~.) :: (Flags a) => a -> a -> Bool
+ Data.Flags: (.~.) :: Flags a => a -> a -> Bool
- Data.Flags: allBut :: (BoundedFlags a) => a -> a
+ Data.Flags: allBut :: BoundedFlags a => a -> a
- Data.Flags: allFlags :: (BoundedFlags a) => a
+ Data.Flags: allFlags :: BoundedFlags a => a
- Data.Flags: andFlags :: (Flags a) => a -> a -> a
+ Data.Flags: andFlags :: Flags a => a -> a -> a
- Data.Flags: butFlags :: (Flags a) => a -> a -> a
+ Data.Flags: butFlags :: Flags a => a -> a -> a
- Data.Flags: class (Flags a) => BoundedFlags a
+ Data.Flags: class Flags a => BoundedFlags a
- Data.Flags: class (Eq a) => Flags a
+ Data.Flags: class Eq a => Flags a
- Data.Flags: commonFlags :: (Flags a) => a -> a -> a
+ Data.Flags: commonFlags :: Flags a => a -> a -> a
- Data.Flags: containsAll :: (Flags a) => a -> a -> Bool
+ Data.Flags: containsAll :: Flags a => a -> a -> Bool
- Data.Flags: containsNone :: (Flags a) => a -> a -> Bool
+ Data.Flags: containsNone :: Flags a => a -> a -> Bool
- Data.Flags: containsSome :: (Flags a) => a -> a -> Bool
+ Data.Flags: containsSome :: Flags a => a -> a -> Bool
- Data.Flags: enumFlags :: (BoundedFlags a) => a -> [a]
+ Data.Flags: enumFlags :: BoundedFlags a => a -> [a]
- Data.Flags: noFlags :: (Flags a) => a
+ Data.Flags: noFlags :: Flags a => a
- Data.Flags.TH: bitmaskWrapper :: String -> Name -> [Name] -> Bool -> [(String, Integer)] -> Q [Dec]
+ Data.Flags.TH: bitmaskWrapper :: String -> Name -> [Name] -> [(String, Integer)] -> Q [Dec]

Files

data-flags.cabal view
@@ -1,5 +1,5 @@ Name: data-flags-Version: 0.0.2+Version: 0.0.3 Category: Data Stability: experimental Synopsis: A package for working with bit masks and flags in general.
src/Data/Flags/TH.hs view
@@ -4,7 +4,8 @@ module Data.Flags.TH (     dataBitsAsFlags,     dataBitsAsBoundedFlags,-    bitmaskWrapper+    bitmaskWrapper,+    enumADT   ) where  import Language.Haskell.TH@@ -12,6 +13,8 @@ import Data.Bits (Bits(..)) import Data.Maybe (isJust) import Data.List (find, union, intercalate)+import Foreign.Storable (Storable(..))+import Foreign.Ptr (Ptr, castPtr) import Control.Applicative ((<$>))  import Data.Flags.Base@@ -48,19 +51,17 @@           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+--   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.-               -> Bool -- ^ Whether to declare BoundedFlags instance.                -> [(String, Integer)] -- ^ Individual flags.                -> Q [Dec]-bitmaskWrapper typeNameS wrappedName derives bounded elems = do+bitmaskWrapper typeNameS wrappedName derives elems = do   typeName <- return $ mkName typeNameS   showE <- [| \flags -> $(stringE $ typeNameS ++ " [") ++                         (intercalate ", " $ map snd $@@ -72,7 +73,7 @@                                      elems)) ++ "]" |]   allFlagsE <- [| foldl andFlags noFlags                     $(listE $ map (varE . mkName . fst) elems) |]-  enumFlagsE <- [| \flags -> filter ((noFlags /=) . commonFlags flags . fst) $+  enumFlagsE <- [| \flags -> filter ((noFlags /=) . commonFlags flags) $                                $(listE $ map (varE . mkName . fst) elems) |]   return $ [NewtypeD [] typeName []                         (NormalC typeName [(NotStrict, ConT wrappedName)]) @@ -85,12 +86,47 @@                                             AppE (ConE typeName)                                                  (LitE $ IntegerL value))                                       []]]) elems) ++-           (if bounded-              then [inst ''BoundedFlags typeName-                      [fun 'allFlags allFlagsE,-                       fun 'enumFlags enumFlagsE]]-              else []) +++           [inst ''BoundedFlags typeName+              [fun 'allFlags allFlagsE,+               fun 'enumFlags enumFlagsE]] ++            (if (isJust $ find (''Show ==) derives)               then []               else [inst ''Show typeName [fun 'show showE]])++-- | 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 typeNameS numName elems = do+  let typeName = mkName typeNameS+      wrap i = caseE (varE i) $+                 (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) ->+                           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)+                  [''Eq, ''Ord, ''Show],+            inst ''Storable typeName+              [fun 'alignment alignmentE,+               fun 'sizeOf sizeOfE,+               fun 'peek peekE,+               fun 'poke pokeE]]