data-flags 0.0.3.1 → 0.0.3.2

raw patch · 4 files changed

+132/−92 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• data-flags.cabal +8/−2
• src/Data/Flags.hs +20/−20
• src/Data/Flags/Base.hs +13/−12
• src/Data/Flags/TH.hs +91/−58

@@ -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 <mikhail.vorozhtsov@gmail.com> Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com> Copyright: 2010 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>@@ -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-

@@ -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)-

@@ -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 ∷ α -> [α]

@@ -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]]-