extensible 0.4 → 0.4.1

raw patch · 11 files changed

+101/−43 lines, 11 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +1/−1
• benchmarks/records.hs +12/−12
• examples/records.hs +14/−16
• extensible.cabal +2/−2
• src/Data/Extensible/Dictionary.hs +10/−0
• src/Data/Extensible/Field.hs +7/−0
• src/Data/Extensible/Label.hs +11/−1
• src/Data/Extensible/Product.hs +12/−6
• src/Data/Extensible/Struct.hs +18/−5
• src/Data/Extensible/Tangle.hs +5/−0

@@ -1,3 +1,12 @@+0.4.1+--------------------------------------------------+* Added `hforce`+* Added an `NFData` instance for `(:*)` and `:|`+* Added a rule to fuse a chain of product updates+* Added a `Monoid` instance for `TangleT`+* Added `(@==)`+* `#foo` can now be overloaded as `FieldOptic "foo"`+ 0.4 --------------------------------------------------- * Added `Data.Extensible.Struct`

@@ -4,6 +4,6 @@ [![Build Status](https://travis-ci.org/fumieval/extensible.svg?branch=master)](https://travis-ci.org/fumieval/extensible) [![Hackage](https://budueba.com/hackage/extensible)](https://hackage.haskell.org/package/extensible) -This package provides extensible poly-kind records and variants.+This package provides extensible poly-kinded records, variants and effects.  Bug reports and contributions are welcome!

@@ -39,14 +39,14 @@   <: nil {-# NOINLINE recB #-} -data HsRec = HsRec { _hsFoo :: !(Sum Int), _hsBar :: !String, _hsBaz :: !(First Int)-  , _hsQux :: !String-  , _hsFooBar :: !(Sum Int, String)-  , _hsFooBaz :: !(Sum Int, First Int)-  , _hsFooQux :: !(Sum Int, String)-  , _hsBarFoo :: !(String, Sum Int)-  , _hsBarBaz :: !(String, First Int)-  , _hsBarQux :: !(String, String)+data HsRec = HsRec { _hsFoo :: Sum Int, _hsBar :: String, _hsBaz :: First Int+  , _hsQux :: String+  , _hsFooBar :: (Sum Int, String)+  , _hsFooBaz :: (Sum Int, First Int)+  , _hsFooQux :: (Sum Int, String)+  , _hsBarFoo :: (String, Sum Int)+  , _hsBarBaz :: (String, First Int)+  , _hsBarQux :: (String, String)   } makeLenses ''HsRec @@ -62,10 +62,10 @@  main = defaultMain   [ bgroup "basic"-    [ bench "view" $ whnf (view foo) recA-    , bench "hsview" $ whnf (view hsFoo) hsRec-    , bench "set" $ whnf (set foo 3) recB-    , bench "hsset" $ whnf (set hsFoo 3) hsRec+    [ bench "view" $ whnf (view foo) $! recA+    , bench "hsview" $ whnf (view hsFoo) $! hsRec+    , bench "set" $ whnf (set foo 3) $! recB+    , bench "hsset" $ whnf (set hsFoo 3) $! hsRec     ]   , bgroup "instances"     [ bench "mappend" $ whnf (uncurry mappend) (recA, recB)

@@ -1,9 +1,7 @@-{-# LANGUAGE TemplateHaskell, DataKinds, TypeOperators, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, FlexibleContexts #-} import Data.Extensible import Control.Lens -mkField "name weight price description featured quantity"- type Stock c = Record '[     "name" >: String   , "weight" >: Float@@ -13,23 +11,23 @@   , "quantity" >: Int]  s0 :: Num c => Stock c-s0 = name @= "DA-192H"-  <: weight @= 260-  <: price @= 120-  <: featured @= True-  <: description @= "High-quality (24bit 192kHz), lightweight portable DAC"-  <: quantity @= 20+s0 = #name @= "DA-192H"+  <: #weight @= 260+  <: #price @= 120+  <: #featured @= True+  <: #description @= "High-quality (24bit 192kHz), lightweight portable DAC"+  <: #quantity @= 20   <: emptyRecord  -- Use shrinkAssoc to permute elements s1 :: Num c => Stock c s1 = shrinkAssoc-   $ name @= "HHP-150"-  <: featured @= False-  <: description @= "Premium wooden headphone"-  <: price @= 330-  <: quantity @= 55-  <: weight @= 200+   $ #name @= "HHP-150"+  <: #featured @= False+  <: #description @= "Premium wooden headphone"+  <: #price @= 330+  <: #quantity @= 55+  <: #weight @= 200   <: emptyRecord  -- If "quantity" is missing,@@ -39,4 +37,4 @@ --    Couldn't match type ‘Ambiguous "quantity"’ with ‘Expecting one’  printSummary :: (Associate "name" String s, Associate "description" String s) => Record s -> IO ()-printSummary s = putStrLn $ view name s ++ ": " ++ view description s+printSummary s = putStrLn $ view #name s ++ ": " ++ view #description s

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4+version:             0.4.1 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -60,7 +60,7 @@     , FlexibleInstances     , PolyKinds     , CPP-  build-depends:       base >= 4.7 && <5+  build-depends:       base >= 4.8 && <5     , template-haskell     , constraints     , ghc-prim

@@ -17,6 +17,7 @@ -- Also includes orphan instances. ----------------------------------------------------------------------- module Data.Extensible.Dictionary (library, WrapForall, Instance1) where+import Control.DeepSeq import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum@@ -53,6 +54,11 @@     (library :: Comp Dict (Instance1 Monoid h) :* xs)   {-# INLINE mappend #-} +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)) ()+  {-# INLINE rnf #-}+ instance WrapForall Show h xs => Show (h :| xs) where   showsPrec d (EmbedAt i h) = showParen (d > 10) $ showString "EmbedAt "     . showsPrec 11 i@@ -70,6 +76,10 @@     Left x -> x     Right Refl -> views (pieceAt p) (\(Comp Dict) -> compare g h) (library :: Comp Dict (Instance1 Ord h) :* xs)   {-# INLINE compare #-}++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 #-}  -- | Forall upon a wrapper type WrapForall c h = Forall (Instance1 c h)

@@ -20,6 +20,7 @@   , (@=)   , (<@=>)   , (@:>)+  , (@==)   , FieldOptic   , FieldName   , liftField@@ -218,3 +219,9 @@ (@:>) :: FieldName k -> h v -> Field h (k ':> v) (@:>) _ = Field infix 1 @:>++-- | Kind-monomorphic, unwrapped version of @('@=')@+(@==) :: FieldName (k :: Symbol) -> v -> Field Identity (k ':> v)+(@==) = (@=)+{-# INLINE (@==) #-}+infix 1 @==

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -18,6 +18,8 @@ import Data.Extensible.Field import Data.Proxy import GHC.OverloadedLabels+import Data.Extensible.Wrapper+import Data.Extensible.Internal.Rig  instance k ~ l => IsLabel k (Proxy l) where   fromLabel _ = Proxy@@ -25,5 +27,13 @@ -- | Specialised version of 'itemAssoc'. 訊 :: Proxy k -> FieldOptic k 訊 = itemAssoc++instance (Extensible f p t+  , Associate k v xs+  , Labelling k p+  , Wrapper h+  , rep ~ Repr h v)+  => IsLabel k (Optic' p f (t (Field h) xs) rep) where+  fromLabel _ = itemAssoc (Proxy :: Proxy k)  #endif

@@ -27,6 +27,8 @@   , htraverse   , htraverseWithIndex   , hsequence+  -- * Evaluating+  , hforce   -- * Update   , haccumMap   , haccum@@ -74,8 +76,7 @@ -- | Convert 'L.HList' into a product. fromHList :: HList.HList h xs -> h :* xs fromHList xs = hfrozen (newFromHList xs)-{-# NOINLINE fromHList #-}-{-# RULES "toHList/fromHList" forall x. toHList (fromHList x) = x #-}+{-# INLINE fromHList #-}  -- | Flipped 'hlookup' hindex :: h :* xs -> Membership xs x ->  h x@@ -194,10 +195,10 @@   => (a -> g :| xs)   -> (forall x. Membership xs x -> g x -> h x -> h x)   -> h :* xs -> f a -> h :* xs-haccumMap f g p0 xs = hfrozen $ do-  s <- thaw p0-  mapM_ (\x -> case f x of EmbedAt i v -> get s i >>= set s i . g i v) xs-  return s+haccumMap f g p0 xs = hmodify+  (\s -> mapM_ (\x -> case f x of EmbedAt i v -> get s i >>= set s i . g i v) xs)+  p0+{-# INLINE haccumMap #-}  -- | @haccum = 'haccumMap' 'id'@ haccum :: Foldable f@@ -210,3 +211,8 @@ hpartition :: (Foldable f, Generate xs) => (a -> h :| xs) -> f a -> Comp [] h :* xs hpartition f = haccumMap f (\_ x (Comp xs) -> Comp (x:xs)) $ hrepeat $ Comp [] {-# INLINE hpartition #-}++-- | Evaluate every element in a product.+hforce :: h :* xs -> h :* xs+hforce p = hfoldrWithIndex (const seq) p p+{-# INLINE hforce #-}

@@ -30,6 +30,7 @@   , hfoldrWithIndex   , thaw   , hfrozen+  , hmodify   , toHList) where  import GHC.Prim@@ -116,6 +117,7 @@    go 0 l   return m+{-# NOINLINE newFromHList #-}  -- | The type of extensible products. --@@ -160,6 +162,8 @@   unknownHList = unsafeCoerce# {-# NOINLINE toHList #-} +{-# RULES "toHList/fromHList" forall x. toHList (hfrozen (newFromHList x)) = x #-}+ -- | Create a new 'Struct' using the contents of a product. newFrom :: forall g h m xs. (PrimMonad m)   => g :* xs@@ -199,13 +203,22 @@ -- | Create a product from an 'ST' action which returns a 'Struct'. hfrozen :: (forall s. ST s (Struct s h xs)) -> h :* xs hfrozen m = runST $ m >>= unsafeFreeze-{-# NOINLINE[0] hfrozen #-}+{-# INLINE[0] hfrozen #-} +hmodify :: (forall s. Struct s h xs -> ST s ()) -> h :* xs -> h :* xs+hmodify f m = runST $ do+  s <- thaw m+  f s+  unsafeFreeze s+{-# INLINE[0] hmodify #-}++{-# RULES "hmodify/batch" forall+  (a :: forall s. Struct s h xs -> ST s ())+  (b :: forall s. Struct s h xs -> ST s ())+  (x :: h :* xs). hmodify b (hmodify a x) = hmodify (\s -> a s >> b s) x  #-}+ instance (Corepresentable p, Comonad (Corep p), Functor f) => Extensible f p (:*) where   -- | A lens for a value in a known position.   pieceAt i pafb = cotabulate $ \ws -> sbt (extract ws) <$> cosieve pafb (hlookup i <$> ws) where-    sbt xs x = hfrozen $ do-      s <- thaw xs-      set s i x-      return s+    sbt xs x = hmodify (\s -> set s i x) xs   {-# INLINE pieceAt #-}

@@ -11,6 +11,7 @@ ------------------------------------------------------------------------ module Data.Extensible.Tangle where +import Control.Applicative import Control.Monad.Trans.RWS.Strict import Control.Monad.Trans.Class import Data.Extensible.Class@@ -27,6 +28,10 @@  instance MonadTrans (TangleT h xs) where   lift = TangleT . lift++instance (Monad m, Monoid a) => Monoid (TangleT h xs m a) where+    mempty = pure mempty+    mappend = liftA2 mappend  -- | Hitch an element associated to the 'FieldName' through a wrapper. lasso :: forall k v m h xs. (Monad m, Associate k v xs, Wrapper h)