extensible 0.4.4 → 0.4.5

raw patch · 14 files changed

+343/−11 lines, 14 filesdep +QuickCheckdep +lensdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, lens

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• extensible.cabal +10/−1
• src/Data/Extensible/Bits.hs +160/−0
• src/Data/Extensible/Class.hs +8/−6
• src/Data/Extensible/Dictionary.hs +22/−0
• src/Data/Extensible/Effect.hs +5/−0
• src/Data/Extensible/Field.hs +3/−0
• src/Data/Extensible/Label.hs +1/−0
• src/Data/Extensible/Nullable.hs +2/−1
• src/Data/Extensible/Plain.hs +1/−1
• src/Data/Extensible/Product.hs +2/−0
• src/Data/Extensible/Struct.hs +21/−0
• src/Data/Extensible/Wrapper.hs +7/−2
• tests/bits.hs +94/−0

@@ -1,3 +1,10 @@+0.4.5+-------------------------------------------------+* Added `nothingEff`+* Added `happend`+* Added `Arbitrary` instances for `:*`, `:|`, and wrappers+* Added `Data.Extensible.Bits`+ 0.4.4 ------------------------------------------------- * Added `contEff` and `runContEff`

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4.4+version:             0.4.5 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -29,6 +29,7 @@ library   exposed-modules:     Data.Extensible+    Data.Extensible.Bits     Data.Extensible.Class     Data.Extensible.Dictionary     Data.Extensible.Field@@ -76,6 +77,7 @@     , mtl     , monad-skeleton >= 0.1.2     , StateVar+    , QuickCheck   hs-source-dirs:      src   ghc-options: -Wall   default-language:    Haskell2010@@ -84,5 +86,12 @@   type: exitcode-stdio-1.0   main-is: effects.hs   build-depends: base, extensible+  hs-source-dirs: tests+  default-language:    Haskell2010++test-suite bits+  type: exitcode-stdio-1.0+  main-is: bits.hs+  build-depends: base, extensible, lens, QuickCheck, template-haskell   hs-source-dirs: tests   default-language:    Haskell2010

@@ -0,0 +1,160 @@+{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-}++module Data.Extensible.Bits (BitProd(..)+  , FromBits(..)+  , TotalBits+  , BitFields+  , blookup+  , bupdate+  , toBitProd+  , BitRecordOf+  , BitRecord) where++import Control.Comonad+import Data.Bits+import Data.Extensible.Class+import Data.Extensible.Dictionary+import Data.Extensible.Product+import Data.Extensible.Internal (getMemberId)+import Data.Extensible.Field+import Data.Functor.Identity+import Data.Ix+import Data.Profunctor.Rep+import Data.Profunctor.Sieve+import Data.Proxy+import Data.Word+import Data.Int+import GHC.Generics (Generic)+import GHC.TypeLits++-- | Bit-vector product. It has similar interface as @(:*)@ but fields are packed into @r@.+newtype BitProd r (h :: k -> *) (xs :: [k]) = BitProd { unBitProd :: r }+  deriving (Eq, Ord, Enum, Bounded, Ix, Generic)++type family TotalBits h xs where+  TotalBits h '[] = 0+  TotalBits h (x ': xs) = BitWidth (h x) + TotalBits h xs++-- | Conversion between a value and a bit representation.+--+-- Instances of `FromBits` must satisfy the following laws:+--+-- > fromBits (x `shiftL` W .|. toBits a) ≡ a+-- > toBits a `shiftR` W == zeroBits+--+-- where W is the 'BitWidth'.+class (Bits r, KnownNat (BitWidth a)) => FromBits r a where+  type BitWidth a :: Nat+  fromBits :: r -> a+  toBits :: a -> r++instance FromBits Word64 Word64 where+  type BitWidth Word64 = 64+  fromBits = id+  toBits = id++instance FromBits Word64 Bool where+  type BitWidth Bool = 1+  fromBits = flip testBit 0+  toBits False = 0+  toBits True = 1++instance FromBits Word64 Word8 where+  type BitWidth Word8 = 8+  fromBits = fromIntegral+  toBits = fromIntegral++instance FromBits Word64 Word16 where+  type BitWidth Word16 = 16+  fromBits = fromIntegral+  toBits = fromIntegral++instance FromBits Word64 Word32 where+  type BitWidth Word32 = 32+  fromBits = fromIntegral+  toBits = fromIntegral++instance FromBits Word64 Int8 where+  type BitWidth Int8 = 8+  fromBits = fromIntegral+  toBits = fromIntegral . (fromIntegral :: Int8 -> Word8)++instance FromBits Word64 Int16 where+  type BitWidth Int16 = 16+  fromBits = fromIntegral+  toBits = fromIntegral . (fromIntegral :: Int16 -> Word16)++instance FromBits Word64 Int32 where+  type BitWidth Int32 = 32+  fromBits = fromIntegral+  toBits = fromIntegral . (fromIntegral :: Int32 -> Word32)++instance FromBits r a => FromBits r (Identity a) where+  type BitWidth (Identity a) = BitWidth a+  fromBits = Identity . fromBits+  toBits = toBits . runIdentity++instance (Bits r, FromBits r (h (AssocValue x))) => FromBits r (Field h x) where+  type BitWidth (Field h x) = BitWidth (h (AssocValue x))+  fromBits = Field . fromBits+  toBits = toBits . getField++instance (Bits r, KnownNat (TotalBits h xs)) => FromBits r (BitProd r h xs) where+  type BitWidth (BitProd r h xs) = TotalBits h xs+  fromBits = BitProd+  toBits = unBitProd++-- | Fields are instances of 'FromBits' and fit in the representation.+type BitFields r h xs = (FromBits r r+  , TotalBits h xs <= BitWidth r+  , Forall (Instance1 (FromBits r) h) xs)++-- | Convert a normal extensible record into a bit record.+toBitProd :: forall r h xs. BitFields r h xs => h :* xs -> BitProd r h xs+toBitProd p = hfoldrWithIndexFor (Proxy :: Proxy (Instance1 (FromBits r) h))+  (\i v f r -> f $! bupdate i r v) id p (BitProd zeroBits)++-- | 'hlookup' for 'BitProd'+blookup :: forall x r h xs.+  (BitFields r h xs, FromBits r (h x))+  => Membership xs x -> BitProd r h xs -> h x+blookup i (BitProd r) = fromBits $ unsafeShiftR r+  $ bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs)+  $ getMemberId i+{-# INLINE blookup #-}++-- | Update a field of a 'BitProd'.+bupdate :: forall x r h xs.+  (BitFields r h xs, FromBits r (h x))+  => Membership xs x -> BitProd r h xs -> h x -> BitProd r h xs+bupdate i (BitProd r) a = BitProd $ r .&. mask+  .|. unsafeShiftL (toBits a) offset+  where+    mask = unsafeShiftL (complement zeroBits) width `rotateL` offset+    width = fromInteger $ natVal (Proxy :: Proxy (BitWidth (h x)))+    offset = bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs) $ getMemberId i+{-# INLINE bupdate #-}++bitOffsetAt :: forall r h xs. Forall (Instance1 (FromBits r) h) xs+  => Proxy (r :: *) -> Proxy (h :: k -> *) -> Proxy (xs :: [k]) -> Int -> Int+bitOffsetAt _ ph _ = henumerateFor+  (Proxy :: Proxy (Instance1 (FromBits r) h))+  (Proxy :: Proxy xs)+  (\m r o i -> if i == 0+    then o+    else r (fromInteger (natVal (proxyBitWidth ph m)) + o) (i - 1))+  (error "Impossible") 0++proxyBitWidth :: Proxy h -> proxy x -> Proxy (BitWidth (h x))+proxyBitWidth _ _ = Proxy++type BitRecordOf r h = BitProd r (Field h)+type BitRecord r = BitRecordOf r Identity++instance (Corepresentable p, Comonad (Corep p), Functor f) => Extensible f p (BitProd r) where+  type ExtensibleConstr (BitProd r) h xs x+    = (BitFields r h xs, FromBits r (h x))+  pieceAt i pafb = cotabulate $ \ws -> bupdate i (extract ws) <$> cosieve pafb (blookup i <$> ws)+  {-# INLINE pieceAt #-}

@@ -59,30 +59,32 @@  -- | This class allows us to use 'pieceAt' for both sums and products. class (Functor f, Profunctor p) => Extensible f p (t :: (k -> *) -> [k] -> *) where-  pieceAt :: Membership xs x -> Optic' p f (t h xs) (h x)+  type ExtensibleConstr t (h :: k -> *) (xs :: [k]) (x :: k) :: Constraint+  type ExtensibleConstr t h xs x = ()+  pieceAt :: ExtensibleConstr t h xs x => Membership xs x -> Optic' p f (t h xs) (h x)  -- | Accessor for an element.-piece :: (x ∈ xs, Extensible f p t) => Optic' p f (t h xs) (h x)+piece :: (x ∈ xs, Extensible f p t, ExtensibleConstr t h xs x) => Optic' p f (t h xs) (h x) piece = pieceAt membership {-# INLINE piece #-}  -- | Like 'piece', but reckon membership from its key.-pieceAssoc :: (Associate k v xs, Extensible f p t) => Optic' p f (t h xs) (h (k ':> v))+pieceAssoc :: (Associate k v xs, Extensible f p t, ExtensibleConstr t h xs (k ':> v)) => Optic' p f (t h xs) (h (k ':> v)) pieceAssoc = pieceAt association {-# INLINE pieceAssoc #-}  -- | Access a specified element through a wrapper.-itemAt :: (Wrapper h, Extensible f p t) => Membership xs x -> Optic' p f (t h xs) (Repr h x)+itemAt :: (Wrapper h, Extensible f p t, ExtensibleConstr t h xs x) => Membership xs x -> Optic' p f (t h xs) (Repr h x) itemAt m = pieceAt m . _Wrapper {-# INLINE itemAt #-}  -- | Access an element through a wrapper.-item :: (Wrapper h, Extensible f p t, x ∈ xs) => proxy x -> Optic' p f (t h xs) (Repr h x)+item :: (Wrapper h, Extensible f p t, x ∈ xs, ExtensibleConstr t h xs x) => proxy x -> Optic' p f (t h xs) (Repr h x) item p = piece . _WrapperAs p {-# INLINE item #-}  -- | Access an element specified by the key type through a wrapper.-itemAssoc :: (Wrapper h, Extensible f p t, Associate k v xs)+itemAssoc :: (Wrapper h, Extensible f p t, Associate k v xs, ExtensibleConstr t h xs (k ':> v))   => proxy k -> Optic' p f (t h xs) (Repr h (k ':> v)) itemAssoc p = pieceAssoc . _WrapperAs (proxyKey p) {-# INLINE itemAssoc #-}

@@ -24,8 +24,11 @@ import Data.Extensible.Internal import Data.Extensible.Internal.Rig import Data.Constraint+import Data.Extensible.Struct import Data.Extensible.Wrapper import Data.Semigroup+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen  -- | Reify a collection of dictionaries, as you wish. library :: forall c xs. Forall c xs => Comp Dict c :* xs@@ -64,6 +67,13 @@   minBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) minBound   maxBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) maxBound +instance WrapForall Arbitrary h xs => Arbitrary (h :* xs) where+  arbitrary = hgenerateFor (Proxy :: Proxy (Instance1 Arbitrary h)) (const arbitrary)+  shrink xs = henumerateFor (Proxy :: Proxy (Instance1 Arbitrary h))+    (Proxy :: Proxy xs) (\i -> (++)+    $ map (\x -> hmodify (\s -> set s i x) xs) $ shrink $ hindex xs i)+    []+ instance WrapForall NFData h xs => NFData (h :* xs) where   rnf xs = henumerateFor (Proxy :: Proxy (Instance1 NFData h)) (Proxy :: Proxy xs)     (\i -> deepseq (hlookup i xs)) ()@@ -90,6 +100,18 @@ instance WrapForall NFData h xs => NFData (h :| xs) where   rnf (EmbedAt i h) = views (pieceAt i) (\(Comp Dict) -> rnf h) (library :: Comp Dict (Instance1 NFData h) :* xs)   {-# INLINE rnf #-}++instance WrapForall Arbitrary h xs => Arbitrary (h :| xs) where+  arbitrary = choose (0, hcount (Proxy :: Proxy xs)) >>= henumerateFor+      (Proxy :: Proxy (Instance1 Arbitrary h))+      (Proxy :: Proxy xs)+      (\m r i -> if i == 0+        then EmbedAt m <$> arbitrary+        else r (i - 1))+        (error "Impossible")+  shrink (EmbedAt i h) = views (pieceAt i)+    (\(Comp Dict) -> EmbedAt i <$> shrink h)+    (library :: Comp Dict (Instance1 Arbitrary h) :* xs)  -- | Forall upon a wrapper type WrapForall c h = Forall (Instance1 c h)

@@ -66,6 +66,7 @@   , execWriterEff   -- ** Maybe   , MaybeEff+  , nothingEff   , runMaybeEff   -- ** Either   , EitherEff@@ -398,6 +399,10 @@  -- | An effect with no result type MaybeEff = Const ()++-- | Break out of the computation. Similar to 'Nothing'.+nothingEff :: Associate k MaybeEff xs => Proxy k -> Eff xs a+nothingEff = flip throwEff ()  -- | Run an effect which may fail in the name of @k@. runMaybeEff :: forall k xs a. Eff (k >: MaybeEff ': xs) a -> Eff xs (Maybe a)

@@ -61,6 +61,7 @@ import Foreign.Storable (Storable) import GHC.Generics (Generic) import GHC.TypeLits hiding (Nat)+import Test.QuickCheck.Arbitrary  -- | Take the type of the key type family AssocKey (kv :: Assoc k v) :: k where@@ -102,6 +103,7 @@ ND_Field(Enum) ND_Field(Bounded) ND_Field(NFData)+ND_Field(Arbitrary)  -- | Lift a function for the content. liftField :: (g (AssocValue kv) -> h (AssocValue kv)) -> Field g kv -> Field h kv@@ -179,6 +181,7 @@ type FieldOptic k = forall f p t xs (h :: kind -> *) (v :: kind). #endif   (Extensible f p t+  , ExtensibleConstr t (Field h) xs (k ':> v)   , Associate k v xs   , Labelling k p   , Wrapper h)

@@ -35,6 +35,7 @@   , Associate k v xs   , Labelling k p   , Wrapper h+  , ExtensibleConstr e (Field h) xs (k ':> v)   , rep ~ Repr h v   , s ~ e (Field h) xs   , s ~ t

@@ -28,10 +28,11 @@ import Data.Profunctor.Unsafe import Data.Semigroup import GHC.Generics (Generic)+import Test.QuickCheck.Arbitrary  -- | Wrapped Maybe newtype Nullable h x = Nullable { getNullable :: Maybe (h x) }-  deriving (Show, Eq, Ord, Typeable, Generic, NFData)+  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Arbitrary)  instance Wrapper h => Wrapper (Nullable h) where   type Repr (Nullable h) x = Maybe (Repr h x)

@@ -56,6 +56,6 @@ infixr 1 <%|  -- | An accessor for newtype constructors.-accessing :: (Coercible x a, x ∈ xs, Extensible f p t) => (a -> x) -> Optic' p f (t Identity xs) a+accessing :: (Coercible x a, x ∈ xs, Extensible f p t, ExtensibleConstr t Identity xs x) => (a -> x) -> Optic' p f (t Identity xs) a accessing c = piece . _Wrapper . dimap coerce (fmap c) {-# INLINE accessing #-}

@@ -18,6 +18,8 @@   , (<:)   , (<!)   , hlength+  , type (++)+  , happend   , hmap   , hmapWithIndex   , hzipWith

@@ -1,7 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns, BangPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------ -- | -- Module      :  Data.Extensible.Struct@@ -34,6 +36,8 @@   , newFrom   , hlookup   , hlength+  , type (++)+  , happend   , hfoldrWithIndex   , thaw   , hfrozen@@ -212,6 +216,23 @@ hlength :: h :* xs -> Int hlength (HProduct ar) = I# (sizeofSmallArray# ar) {-# INLINE hlength #-}++type family (++) (xs :: [k]) (ys :: [k]) :: [k] where+  '[] ++ ys = ys+  (x ': xs) ++ ys = x ': xs ++ ys++infixr 5 ++++-- | Combine products.+happend :: (h :* xs) -> (h :* ys) -> (h :* (xs ++ ys))+happend (HProduct lhs) (HProduct rhs) = runST $ primitive $ \s0 ->+  let lhsSz = sizeofSmallArray# lhs+      rhsSz = sizeofSmallArray# rhs+  in  case newSmallArray# (lhsSz +# rhsSz) undefined s0 of { (# s1, a #) ->+      case copySmallArray# lhs 0# a 0# lhsSz s1 of { s2 ->+      case copySmallArray# rhs 0# a lhsSz rhsSz s2 of { s3 ->+      case unsafeFreezeSmallArray# a s3 of { (# s4, frz #) ->+      (# s4, HProduct frz #) }}}}  unsafeMembership :: Int -> Membership xs x unsafeMembership = unsafeCoerce#

@@ -26,6 +26,7 @@ import Data.Extensible.Internal.Rig import Data.Semigroup import GHC.Generics (Generic)+import Test.QuickCheck.Arbitrary  -- | The extensible data types should take @k -> *@ as a parameter. -- This class allows us to take a shortcut for direct representation.@@ -60,7 +61,7 @@  -- | Poly-kinded composition newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }-  deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid)+  deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid, Arbitrary)  deriving instance (Functor f, Functor g) => Functor (Comp f g) deriving instance (Foldable f, Foldable g) => Foldable (Comp f g)@@ -78,7 +79,7 @@  -- | Poly-kinded Const newtype Const' a x = Const' { getConst' :: a }-  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Functor, Foldable, Traversable)+  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Functor, Foldable, Traversable, Arbitrary)  instance Wrapper (Const' a) where   type Repr (Const' a) b = a@@ -107,3 +108,7 @@ instance (Monoid (f a), Monoid (g a)) => Monoid (Prod f g a) where   mempty = Prod mempty mempty   Prod a b `mappend` Prod c d = Prod (mappend a c) (mappend b d)++instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Prod f g a) where+  arbitrary = Prod <$> arbitrary <*> arbitrary+  shrink (Prod a b) = Prod a `map` shrink b ++ flip Prod b `map` shrink a

@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Lens+import Data.Bits+import Data.Extensible+import Data.Extensible.Bits+import Data.Int+import Data.Proxy+import Data.Word+import GHC.TypeLits+import Language.Haskell.TH (mkName)+import Test.QuickCheck++type Fields = ["a" >: Bool, "b" >: Word8, "c" >: Bool]++mkFieldAs (mkName "_a") "a"+mkFieldAs (mkName "_b") "b"+mkFieldAs (mkName "_c") "c"+++prop_lensA1 x r = set _a x (BitProd r :: Rec) ^. _a == x+prop_lensA2 b = let r = BitProd b :: Rec+  in set _a (r ^. _a) r == r+prop_lensA3 b x y = let r = BitProd b :: Rec+  in set _a x (set _a y r) == set _a x r++prop_lensB1 x r = set _b x (BitProd r :: Rec) ^. _b == x+prop_lensB2 b = let r = BitProd b :: Rec+  in set _b (r ^. _b) r == r+prop_lensB3 b x y = let r = BitProd b :: Rec+  in set _b x (set _b y r) == set _b x r++prop_lensC1 x r = set _c x (BitProd r :: Rec) ^. _c == x+prop_lensC2 b = let r = BitProd b :: Rec+  in set _c (r ^. _c) r == r+prop_lensC3 b x y = let r = BitProd b :: Rec+  in set _c x (set _c y r) == set _c x r++type Rec = BitRecord Word64 Fields++focus :: forall a. (Eq a, Show a) => FromBits Word64 a => Word64 -> a -> Property+focus x a = let w = fromIntegral $ natVal (Proxy :: Proxy (BitWidth a))+  in fromBits (x `shiftL` w .|. toBits a) === a++clean :: forall a. Eq a => FromBits Word64 a => a -> Property+clean a = let w = fromIntegral $ natVal (Proxy :: Proxy (BitWidth a))+  in toBits a `shiftR` w === (zeroBits :: Word64)++prop_focus_Word8 :: Word64 -> Word8 -> Property+prop_focus_Word8 = focus++prop_clean_Word8 :: Word8 -> Property+prop_clean_Word8 = clean++prop_focus_Word16 :: Word64 -> Word16 -> Property+prop_focus_Word16 = focus++prop_clean_Word16 :: Word16 -> Property+prop_clean_Word16 = clean++prop_focus_Word32 :: Word64 -> Word32 -> Property+prop_focus_Word32 = focus++prop_clean_Word32 :: Word32 -> Property+prop_clean_Word32 = clean++prop_focus_Int8 :: Word64 -> Int8 -> Property+prop_focus_Int8 = focus++prop_clean_Int8 :: Int8 -> Property+prop_clean_Int8 = clean++prop_focus_Int16 :: Word64 -> Int16 -> Property+prop_focus_Int16 = focus++prop_clean_Int16 :: Int16 -> Property+prop_clean_Int16 = clean++prop_focus_Int32 :: Word64 -> Int32 -> Property+prop_focus_Int32 = focus++prop_clean_Int32 :: Int32 -> Property+prop_clean_Int32 = clean++prop_focus_Bool :: Word64 -> Bool -> Property+prop_focus_Bool = focus++prop_clean_Bool :: Bool -> Property+prop_clean_Bool = clean++return []+main = $quickCheckAll