extensible 0.4.1 → 0.4.2

raw patch · 8 files changed

+138/−12 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +1/−1
• examples/effect.hs +1/−2
• extensible.cabal +1/−1
• src/Data/Extensible/Effect.hs +46/−5
• src/Data/Extensible/Label.hs +8/−1
• src/Data/Extensible/Product.hs +28/−0
• src/Data/Extensible/Struct.hs +44/−2

@@ -1,3 +1,12 @@+0.4.2+-------------------------------------------------+* Made `newFrom` strict+* `pieceAt` for `(:*)` is now strict+* Added `(<!)`+* Added `peelEff1`, `peelAction0`, `execStateEff`, `execWriterEff`+* Added atomic operations for `Struct`+* Added constrained variants of folds+ 0.4.1 -------------------------------------------------- * Added `hforce`

@@ -2,7 +2,7 @@ ======================  [![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)+[![Hackage](https://img.shields.io/hackage/v/extensible.svg)](https://hackage.haskell.org/package/extensible)  This package provides extensible poly-kinded records, variants and effects. 

@@ -44,5 +44,4 @@   <: nil  takePrintString :: MonadIO (Eff xs) => Eff (PrintString ': xs) a -> Eff xs a-takePrintString = peelAction rebindEff0 return-  $ \str cont -> liftIO (putStrLn str) >>= cont+takePrintString = peelAction0 $ liftIO . putStrLn

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4.1+version:             0.4.2 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues

@@ -26,6 +26,7 @@   , Rebinder   , rebindEff0   , rebindEff1+  , peelEff1   , rebindEff2   , leaveEff   , retractEff@@ -35,6 +36,7 @@   , runAction   , (@!?)   , peelAction+  , peelAction0   -- * transformers-compatible actions and handlers   -- ** Reader   , ReaderEff@@ -50,6 +52,7 @@   , modifyEff   , stateEff   , runStateEff+  , execStateEff   -- ** Writer   , WriterEff   , writerEff@@ -57,6 +60,7 @@   , listenEff   , passEff   , runWriterEff+  , execWriterEff   -- ** Maybe   , MaybeEff   , runMaybeEff@@ -110,7 +114,7 @@ -- | Build a relay-style handler from a triple of functions. -- -- @--- runStateEff = peelEff rebindEff1 (\a s -> return (a, s))+-- runStateEff = peelEff1 (\a s -> return (a, s)) --   (\m k s -> let (a, s') = runState m s in k a s') -- @ --@@ -127,6 +131,13 @@       (\j -> pass (Instruction j t) (go . k)) {-# INLINE peelEff #-} +-- | 'peelEff' specialised for 1-argument continuation+peelEff1 :: (a -> b -> Eff xs r) -- ^ return the result+  -> (forall x. t x -> (x -> b -> Eff xs r) -> b -> Eff xs r) -- ^ Handle the foremost type of an action+  -> Eff (k >: t ': xs) a -> b -> Eff xs r+peelEff1 = peelEff rebindEff1+{-# INLINE peelEff1 #-}+ -- | A function to bind an 'Instruction' in 'peelEff'. type Rebinder xs r = forall x. Instruction xs x -> (x -> r) -> r @@ -209,6 +220,22 @@       (\j -> pass (Instruction j t) (go . k)) {-# INLINE peelAction #-} +-- | Non continuation-passing variant of 'peelAction'.+peelAction0 :: forall k ps q xs a. Function ps (Eff xs q) -- ^ Handle the foremost action+  -> Eff (k >: Action ps q ': xs) a -> Eff xs a+peelAction0 wrap = go where+  go m = case debone m of+    Return a -> return a+    Instruction i t :>>= k -> runMembership i+      (\Refl -> case t of+        (_ :: Action ps q x) ->+          let run :: forall t. Function t (Eff xs q) -> Action t q x -> Eff xs a+              run f AResult = f >>= go . k+              run f (AArgument x a) = run (f x) a+          in run wrap t)+      (\j -> rebindEff0 (Instruction j t) (go . k))+{-# INLINE peelAction0 #-}+ -- | The reader monad is characterised by a type equality between the result -- type and the enviroment type. type ReaderEff = (:~:)@@ -273,12 +300,19 @@ stateEff k = liftEff k . state {-# INLINE stateEff #-} +contState :: State s a -> (a -> s -> r) -> s -> r+contState m k s = let (a, s') = runState m s in k a $! s'+ -- | Run the frontal state effect. runStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs (a, s)-runStateEff = peelEff rebindEff1 (\a s -> return (a, s))-  (\m k s -> let (a, s') = runState m s in k a $! s')+runStateEff = peelEff1 (\a s -> return (a, s)) contState {-# INLINE runStateEff #-} +-- | Run the frontal state effect.+execStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs s+execStateEff = peelEff1 (const return) contState+{-# INLINE execStateEff #-}+ -- | @(,)@ already is a writer monad. type WriterEff w = (,) w @@ -318,11 +352,18 @@                         !w'' = mappend w w' in go w'' (k a) {-# INLINE passEff #-} +contWriter :: Monoid w => (w, a) -> (a -> w -> r) -> w -> r+contWriter (w', a) k w = k a $! mappend w w'+ -- | Run the frontal writer effect. runWriterEff :: forall k w xs a. Monoid w => Eff (k >: WriterEff w ': xs) a -> Eff xs (a, w)-runWriterEff = peelEff rebindEff1 (\a w -> return (a, w))-  (\(w', a) k w -> k a $! mappend w w') `flip` mempty+runWriterEff = peelEff1 (\a w -> return (a, w)) contWriter `flip` mempty {-# INLINE runWriterEff #-}++-- | Run the frontal state effect.+execWriterEff :: forall k w xs a. Monoid w => Eff (k >: WriterEff w ': xs) a -> Eff xs w+execWriterEff = peelEff1 (const return) contWriter `flip` mempty+{-# INLINE execWriterEff #-}  -- | An effect with no result type MaybeEff = Const ()

@@ -22,7 +22,11 @@ import Data.Extensible.Internal.Rig  instance k ~ l => IsLabel k (Proxy l) where+#if __GLASGOW_HASKELL__ >= 802+  fromLabel = Proxy+#else   fromLabel _ = Proxy+#endif  -- | Specialised version of 'itemAssoc'. 訊 :: Proxy k -> FieldOptic k@@ -34,6 +38,9 @@   , Wrapper h   , rep ~ Repr h v)   => IsLabel k (Optic' p f (t (Field h) xs) rep) where+#if __GLASGOW_HASKELL__ >= 802+  fromLabel = itemAssoc (Proxy :: Proxy k)+#else   fromLabel _ = itemAssoc (Proxy :: Proxy k)-+#endif #endif

@@ -16,6 +16,7 @@   (:*)   , nil   , (<:)+  , (<!)   , hlength   , hmap   , hmapWithIndex@@ -27,6 +28,10 @@   , htraverse   , htraverseWithIndex   , hsequence+  -- * Constrained fold+  , hfoldMapFor+  , hfoldMapWithIndexFor+  , hfoldrWithIndexFor   -- * Evaluating   , hforce   -- * Update@@ -67,6 +72,12 @@ {-# INLINE (<:) #-} infixr 0 <: +-- | Strict version of ('<:').+(<!) :: h x -> h :* xs -> h :* (x ': xs)+(<!) x = fromHList . (HList.HCons $! x) . toHList+{-# INLINE (<!) #-}+infixr 0 <!+ -- | An empty product. nil :: h :* '[] nil = hfrozen $ new $ error "Impossible"@@ -120,6 +131,23 @@   => (forall x. Membership xs x -> g x -> a) -> g :* xs -> a hfoldMapWithIndex f = hfoldrWithIndex (\i -> mappend . f i) mempty {-# INLINE hfoldMapWithIndex #-}++-- | 'hfoldrWithIndex' with a constraint for each element.+hfoldrWithIndexFor :: (Forall c xs) => proxy c+  -> (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> h :* xs -> r+hfoldrWithIndexFor p f r xs = henumerateFor p xs (\i -> f i (hlookup i xs)) r+{-# INLINE hfoldrWithIndexFor #-}++-- | 'hfoldMapWithIndex' with a constraint for each element.+hfoldMapWithIndexFor :: (Forall c xs, Monoid a) => proxy c+  -> (forall x. c x => Membership xs x -> h x -> a) -> h :* xs -> a+hfoldMapWithIndexFor p f = hfoldrWithIndexFor p (\i -> mappend . f i) mempty+{-# INLINE hfoldMapWithIndexFor #-}++hfoldMapFor :: (Forall c xs, Monoid a) => proxy c+  -> (forall x. c x => h x -> a) -> h :* xs -> a+hfoldMapFor p f = hfoldMapWithIndexFor p (const f)+{-# INLINE hfoldMapFor #-}  -- | Traverse all elements and combine the result sequentially. -- @

@@ -21,6 +21,11 @@   , newRepeat   , newFor   , newFromHList+  -- ** Atomic operations+  , atomicModify+  , atomicModify'+  , atomicModify_+  , atomicModify'_   -- * Immutable product   , (:*)   , unsafeFreeze@@ -60,6 +65,43 @@ get (Struct m) (getMemberId -> I# i) = primitive $ unsafeCoerce# readSmallArray# m i {-# INLINE get #-} +atomicModify :: PrimMonad m+  => Struct (PrimState m) h xs -> Membership xs x -> (h x -> (h x, a)) -> m a+atomicModify (Struct m) (getMemberId -> I# i) f = primitive+  $ \s0 -> case readSmallArray# m i s0 of+    (# s, x #) -> retry x s+  where+    retry x s = let p = unsafeCoerce# f x in+      case casSmallArray# m i x (fst p) s of+        (# s', b, y #) -> case b of+          0# -> (# s', snd p #)+          _ -> retry y s'+{-# INLINE atomicModify #-}++atomicModify' :: PrimMonad m+  => Struct (PrimState m) h xs -> Membership xs x -> (h x -> (h x, a)) -> m a+atomicModify' s i f = atomicModify s i+  (\x -> let (y, a) = f x in (y, y `seq` a))+  >>= (return $!)+{-# INLINE atomicModify' #-}++atomicModify_ :: PrimMonad m+  => Struct (PrimState m) h xs -> Membership xs x -> (h x -> h x) -> m (h x)+atomicModify_ (Struct m) (getMemberId -> I# i) f = primitive+  $ \s0 -> case readSmallArray# m i s0 of+    (# s, x #) -> retry x s+  where+    retry x s = case casSmallArray# m i x (unsafeCoerce# f x) s of+      (# s', b, y #) -> case b of+        0# -> (# s', unsafeCoerce# y #)+        _ -> retry y s'+{-# INLINE atomicModify_ #-}++atomicModify'_ :: PrimMonad m+  => Struct (PrimState m) h xs -> Membership xs x -> (h x -> h x) -> m (h x)+atomicModify'_ s i f = atomicModify_ s i f >>= (return $!)+{-# INLINE atomicModify'_ #-}+ -- | Create a new 'Struct' using the supplied initializer. new :: forall h m xs. (PrimMonad m, Generate xs)   => (forall x. Membership xs x -> h x)@@ -177,7 +219,7 @@         | i == I# n = return st         | otherwise = do           let !m = unsafeMembership i-          set st m $ k m (hlookup m hp)+          set st m $! k m (hlookup m hp)           go (i + 1)   go 0 {-# NOINLINE newFrom #-}@@ -220,5 +262,5 @@ 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 = hmodify (\s -> set s i x) xs+    sbt xs !x = hmodify (\s -> set s i x) xs   {-# INLINE pieceAt #-}