polysemy-zoo 0.6.0.1 → 0.7.0.0

raw patch · 11 files changed

+338/−185 lines, 11 filesdep +compactdep +exceptionsdep +streamingdep −binarydep −bytestringdep −hedisdep ~polysemydep ~polysemy-pluginnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: compact, exceptions, streaming, text

Dependencies removed: binary, bytestring, hedis

Dependency ranges changed: polysemy, polysemy-plugin

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• polysemy-zoo.cabal +14/−12
• src/Polysemy/Alias.hs +0/−6
• src/Polysemy/ConstraintAbsorber/MonadCatch.hs +125/−0
• src/Polysemy/Input/Streaming.hs +86/−0
• src/Polysemy/KVStore.hs +0/−33
• src/Polysemy/Reader/Compact.hs +37/−0
• src/Polysemy/Redis/Utils.hs +0/−24
• src/Polysemy/SetStore.hs +1/−32
• src/Polysemy/Tagged.hs +0/−77
• test/ConstraintAbsorberSpec.hs +57/−1

@@ -1,5 +1,23 @@ # Changelog for polysemy-zoo +## 0.7.0.0 (2020-02-14)+### Breaking Changes+- `Tagged` has been migrated to `polysemy` proper.+- `Polysemy.Alias` and `InterpreterOf` has been removed in favor of+    `InterpreterFor`, which is now part of `polysemy` proper+    (thanks to @bolt12).+- Removed `runKVStoreInRedis`, `runSetStoreInRedis`, and `Polysemy.Redis.Utils`+    due to lack of use.++### Other Changes+- Added `MonadThrow` and `MonadCatch` constraint absorbers which operate+    via `Error SomeException` (thanks to @adamConnerSax).+- Added `Polysemy.Input.Streaming`, which offers+    [streaming](https://hackage.haskell.org/package/streaming) interoperability.+- Added `Polysemy.Reader.Compact`, which is useful for `Reader` effects+    which provide a large structure (thanks to @spacekitteh).++ ## 0.6.0.1 (2019-09-12)  - Fixed the implementation of `atomicPut`

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 508b2d70f45ca899d68cc756e99c4a93128f7748848feefea756030db96c9c94+-- hash: 3ca3f0fd7140b4210529e77e057687ebd67bb4477155611458e964afa5cdc192  name:           polysemy-zoo-version:        0.6.0.1+version:        0.7.0.0 synopsis:       Experimental, user-contributed effects and interpreters for polysemy description:    Please see the README on GitHub at <https://github.com/isovector/polysemy-zoo#readme> category:       Polysemy@@ -29,9 +29,9 @@  library   exposed-modules:-      Polysemy.Alias       Polysemy.Capture       Polysemy.ConstraintAbsorber+      Polysemy.ConstraintAbsorber.MonadCatch       Polysemy.ConstraintAbsorber.MonadCont       Polysemy.ConstraintAbsorber.MonadError       Polysemy.ConstraintAbsorber.MonadReader@@ -48,17 +48,17 @@       Polysemy.Floodgate       Polysemy.Fresh       Polysemy.IdempotentLowering+      Polysemy.Input.Streaming       Polysemy.KVStore       Polysemy.Operators       Polysemy.Random+      Polysemy.Reader.Compact       Polysemy.Reader.More-      Polysemy.Redis.Utils       Polysemy.RevState       Polysemy.SetStore       Polysemy.Several       Polysemy.Shift       Polysemy.Shift.Internal-      Polysemy.Tagged   other-modules:       Paths_polysemy_zoo   hs-source-dirs:@@ -68,18 +68,19 @@   build-depends:       async >=2.2 && <3     , base >=4.9 && <5-    , binary >=0.8.5.1 && <0.9-    , bytestring >=0.10.8.2 && <0.11+    , compact >=0.1.0.1     , constraints >=0.10.1 && <0.12     , containers >=0.5 && <0.7     , contravariant <2+    , exceptions >=0.10.0 && <0.11     , ghc-prim >=0.5.2 && <0.6-    , hedis >=0.10 && <0.13     , mtl >=2.0.1.0 && <3.0.0.0-    , polysemy >=1.2.0.0+    , polysemy >=1.2.1.0     , polysemy-plugin >=0.2     , random >=1.1 && <1.2     , reflection >=2.1.4 && <3.0.0+    , streaming+    , text >=1.1.0 && <1.3     , transformers >=0.5.2.0 && <0.6   default-language: Haskell2010 @@ -107,13 +108,12 @@   build-depends:       async >=2.2 && <3     , base >=4.9 && <5-    , binary >=0.8.5.1 && <0.9-    , bytestring >=0.10.8.2 && <0.11+    , compact >=0.1.0.1     , constraints >=0.10.1 && <0.12     , containers >=0.5 && <0.7     , contravariant <2+    , exceptions >=0.10.0 && <0.11     , ghc-prim >=0.5.2 && <0.6-    , hedis >=0.10 && <0.13     , hspec >=2.6.0 && <3     , mtl >=2.0.1.0 && <3.0.0.0     , polysemy >=1.2.0.0@@ -121,5 +121,7 @@     , polysemy-zoo     , random >=1.1 && <1.2     , reflection >=2.1.4 && <3.0.0+    , streaming+    , text >=1.1.0 && <1.3     , transformers >=0.5.2.0 && <0.6   default-language: Haskell2010

@@ -1,6 +0,0 @@-module Polysemy.Alias where--import Polysemy--type InterpreterOf e r = forall x.  Sem (e ': r) x -> Sem r x-

@@ -0,0 +1,125 @@+{-# LANGUAGE AllowAmbiguousTypes         #-}+{-# LANGUAGE FlexibleContexts            #-}+{-# LANGUAGE GADTs                       #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE RankNTypes                  #-}+{-# LANGUAGE ScopedTypeVariables         #-}+{-# LANGUAGE TypeApplications            #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadCatch+  (+    -- * Constraint Absorbers+    absorbMonadThrow+  , absorbMonadCatch+  -- * run helper+  , runMonadCatch+  , runMonadCatchAsText+    -- * Re-exports+  , Exception(..)+  , SomeException+  )+where++import qualified Control.Monad.Catch           as C+import           Control.Monad.Catch            ( Exception(..)+                                                , SomeException+                                                , toException+                                                )++import qualified Data.Text                     as T+import           Polysemy+import           Polysemy.ConstraintAbsorber+import qualified Polysemy.Error                as E+++------------------------------------------------------------------------------+-- | Like 'E.runError' but applies a given function from 'SomeException'+-- to some other type, typically something less opaque.+-- e.g.:+--  @runErrorForMonadCatch C.displayException@+-- +-- @since 0.7.0.0+runMonadCatch+  :: Exception e+  => (Maybe e -> e')+  -> Sem (E.Error C.SomeException : E.Error e' : r) a+  -> Sem r (Either e' a)+runMonadCatch f = E.runError . E.mapError (f . C.fromException)++runMonadCatchAsText+  :: Sem (E.Error C.SomeException : E.Error T.Text : r) a+  -> Sem r (Either T.Text a)+runMonadCatchAsText = E.runError . E.mapError (T.pack . C.displayException)++++-- | Introduce a local 'S.MonadCatch' constraint on 'Sem' --- allowing it to+-- interop nicely with exceptions+--+-- @since 0.7.0.0+absorbMonadCatch+  :: Member (E.Error C.SomeException) r+  => (C.MonadCatch (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'C.MonadCatch'+       -- or 'C.MonadThrow' for+       -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@.+  -> Sem r a+absorbMonadCatch =+  absorbWithSem @C.MonadCatch @Action (CatchDict E.throw E.catch) (Sub Dict)+{-# INLINABLE absorbMonadCatch #-}++-- | Introduce a local 'S.MonadThrow' constraint on 'Sem' --- allowing it to+-- interop nicely with exceptions+--+-- @since 0.7.0.0+absorbMonadThrow+  :: Member (E.Error C.SomeException) r+  => (C.MonadThrow (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'C.MonadCatch'+       -- or 'C.MonadThrow' for+       -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@.+  -> Sem r a+absorbMonadThrow = absorbMonadCatch+{-# INLINABLE absorbMonadThrow #-}++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Error+data CatchDict m = CatchDict+  { throwM_ :: forall a. C.SomeException -> m a+  , catch_ :: forall a. m a -> (C.SomeException -> m a) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Error dictionary,+-- we can make an instance of @MonadError@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (CatchDict m)+         ) => C.MonadThrow (Action m s') where+  throwM e = Action $ throwM_ (reflect $ Proxy @s') (C.toException e)+  {-# INLINEABLE throwM #-}++instance ( Monad m+         , Reifies s' (CatchDict m)+         )  => C.MonadCatch (Action m s') where+  catch x f =+    let catchF = catch_ (reflect $ Proxy @s')+    in Action $ (action x) `catchF` \e -> case C.fromException e of+      Just e' -> action $ f e'+      _ -> throwM_ (reflect $ Proxy @s') (C.toException e)+  {-# INLINEABLE catch #-}++

@@ -0,0 +1,86 @@+module Polysemy.Input.Streaming+  ( -- * Underlying Effect+    module Polysemy.Input++    -- * Actions+  , yieldInput+  , yieldRace+  , exhaust++    -- * Intepretations+  , runInputViaStream+  , runInputViaInfiniteStream+  ) where++import qualified Control.Concurrent.Async as A+import           Data.Functor.Of+import           Data.Void+import           Polysemy+import           Polysemy.Final+import           Polysemy.Input+import           Polysemy.State+import qualified Streaming as S+import qualified Streaming.Prelude as S++++runInputViaStream+    :: S.Stream (Of i) (Sem r) ()+    -> InterpreterFor (Input (Maybe i)) r+runInputViaStream stream+  = evalState (Just stream)+  . reinterpret ( \Input ->+      get >>= \case+        Nothing -> pure Nothing+        Just s ->+          raise (S.inspect s) >>= \case+            Left () -> pure Nothing+            Right (i :> s') -> do+              put $ Just s'+              pure $ Just i+  )+++runInputViaInfiniteStream+    :: forall i r+     . S.Stream (Of i) (Sem r) Void+    -> InterpreterFor (Input i) r+runInputViaInfiniteStream stream+  = evalState stream+  . reinterpret ( \Input -> do+      s <- get+      raise (S.inspect s) >>= \case+        Left g -> absurd g+        Right (i :> s') -> do+          put s'+          pure i+  )+++yieldRace+    :: Members+        '[ Final IO+         , Input i1+         , Input i2+         ] r+    => S.Stream (S.Of (Either i1 i2)) (Sem r) ()+yieldRace = do+  z <- S.lift $ withStrategicToFinal $ do+         input1 <- runS input+         input2 <- runS input+         pure $ fmap sequenceEither $ A.race input1 input2+  S.yield z+++sequenceEither :: Functor f => Either (f a) (f b) -> f (Either a b)+sequenceEither (Left fa) = Left <$> fa+sequenceEither (Right fb) = Right <$> fb+++yieldInput :: Member (Input i) r => S.Stream (Of i) (Sem r) ()+yieldInput = S.lift input >>= S.yield+++exhaust :: Member (Input i) r => S.Stream (Of i) (Sem r) a+exhaust = S.repeatM input+

@@ -16,18 +16,12 @@     -- * Interpretations   , runKVStoreAsState   , runKVStorePurely-  , runKVStoreInRedis   ) where -import           Control.Monad-import           Data.Binary (Binary)-import           Data.ByteString (ByteString) import qualified Data.Map as M import           Data.Maybe (isJust)-import qualified Database.Redis as R import           Polysemy import           Polysemy.Error-import           Polysemy.Redis.Utils import           Polysemy.State  @@ -104,31 +98,4 @@     -> Sem r (M.Map k v, a) runKVStorePurely m = runState m . runKVStoreAsState {-# INLINE runKVStorePurely #-}---runKVStoreInRedis-    :: ( Member (Embed R.Redis) r-       , Member (Error R.Reply) r-       , Binary k-       , Binary v-       )-    => (k -> ByteString)-    -> Sem (KVStore k v ': r) a-    -> Sem r a-runKVStoreInRedis pf = interpret $ \case-  LookupKV k -> do-    res <- fromEitherM $ R.hget (pf k) $ putForRedis k-    pure $ fmap getFromRedis res--  UpdateKV k Nothing ->-    void . fromEitherM-         . R.hdel (pf k)-         . pure-         $ putForRedis k--  UpdateKV k (Just v) ->-    void . fromEitherM-         . R.hset (pf k) (putForRedis k)-         $ putForRedis v-{-# INLINE runKVStoreInRedis #-} 

@@ -0,0 +1,37 @@+module Polysemy.Reader.Compact where++import           Polysemy+import           Polysemy.Reader++import           Data.Compact++-----------------------------------------------------------------------------+-- | Run a 'Reader' effect by compacting a value; otherwise behaves as normal.+-- Useful for 'Reader' effects which provide a large structure.+runReaderWithCompacted+    :: forall r i a+     . Member (Embed IO) r+    => i+    -> Sem (Reader i ': r) a+    -> Sem r a+runReaderWithCompacted i sem = do+    compacted <- embed (compactWithSharing i)+    runReaderWithExistingCompacted compacted sem+{-# INLINE runReaderWithCompacted #-}++-----------------------------------------------------------------------------+-- | Run a 'Reader' effect with a value in a compact region. Will not add +-- 'local' values to the existing region, but will create a new region for it.+runReaderWithExistingCompacted+    :: forall r i a+     . Member (Embed IO) r+    => Compact i+    -> Sem (Reader i ': r) a+    -> Sem r a+runReaderWithExistingCompacted i = interpretH $ \case+    Ask       -> pureT (getCompact i)+    Local f m -> do+        mm <- runT m+        let transformed = f (getCompact i)+        raise $ runReaderWithCompacted transformed mm+{-# INLINE runReaderWithExistingCompacted #-}

@@ -1,24 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Polysemy.Redis.Utils where--import           Data.Binary (Binary)-import qualified Data.Binary as B-import           Data.Binary.Get (runGet)-import           Data.Binary.Put (runPut)-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy.Char8 as L-import           GHC.Exts---newtype Path = Path { getPath :: ByteString }-  deriving (Eq, Ord, Show, IsString)---putForRedis :: Binary a => a -> ByteString-putForRedis = L.toStrict . runPut . B.put---getFromRedis :: Binary a => ByteString -> a-getFromRedis = runGet B.get . L.fromStrict-

@@ -2,16 +2,10 @@  module Polysemy.SetStore where -import           Control.Monad-import           Data.Binary (Binary) import           Data.Foldable import qualified Data.Set as S-import qualified Database.Redis as R import           Polysemy-import           Polysemy.Alias-import           Polysemy.Error import           Polysemy.KVStore-import           Polysemy.Redis.Utils   @@ -27,7 +21,7 @@     :: ( Member (KVStore k (S.Set v)) r        , Ord v        )-    => InterpreterOf (SetStore k v) r+    => Sem (SetStore k v ': r) x -> Sem r x runSetStoreAsKVStore = interpret $ \case   AddS k v ->     lookupKV k >>= \case@@ -39,29 +33,4 @@   MemberS k v ->     pure . maybe False (S.member v) =<< lookupKV k {-# INLINE runSetStoreAsKVStore #-}---runSetStoreInRedis-    :: ( Member (Embed R.Redis) r-       , Member (Error R.Reply) r-       , Binary k-       , Binary v-       )-    => (k -> Path)-    -> InterpreterOf (SetStore k v) r-runSetStoreInRedis pf = interpret $ \case-  AddS k v -> void-            . fromEitherM-            . R.sadd (getPath $ pf k)-            . pure-            $ putForRedis v-  DelS k v -> void-            . fromEitherM-            . R.srem (getPath $ pf k)-            . pure-            $ putForRedis v-  MemberS k v -> fromEitherM-               . R.sismember (getPath $ pf k)-               $ putForRedis v-{-# INLINE runSetStoreInRedis #-} 

@@ -1,77 +0,0 @@-module Polysemy.Tagged-  (-    -- * Effect-    Tagged (..)--    -- * Actions-  , tag--    -- * Interpretations-  , untag-  , retag-  ) where--import Polysemy-import Polysemy.Internal-import Polysemy.Internal.Union------------------------------------------------------------------------------------ | An effect for annotating effects and disambiguating identical effects.-newtype Tagged k e m a where-  Tagged :: forall k e m a. e m a -> Tagged k e m a----------------------------------------------------------------------------------- | Tag uses of an effect, effectively gaining access to the--- tagged effect locally.------ This may be used to create @tagged-@ variants of regular actions.------ For example (the type applications aren't needed when using @polysemy-plugin@):------ @--- taggedLocal :: forall k i r a---              . 'Member' ('Tagged' k ('Polysemy.Reader.Reader' i)) r---             => (i -> i)---             -> 'Sem' r a---             -> 'Sem' r a--- taggedLocal f m =---   'tag' \@k \@('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' \@i f ('raise' m)--- @----tag :: forall k e r a-     . Member (Tagged k e) r-    => Sem (e ': r) a-    -> Sem r a-tag = hoistSem $ \u -> case decomp u of-  Right (Weaving e s wv ex ins) ->-    injWeaving $ Weaving (Tagged e) s (tag . wv) ex ins-  Left g -> hoist tag g-{-# INLINE tag #-}----------------------------------------------------------------------------------- | Run a @'Tagged' k e@ effect through reinterpreting it to @e@-untag :: forall k e r a-       . Sem (Tagged k e ': r) a-      -> Sem (e ': r) a--- TODO(KingoftheHomeless): I think this is safe to replace with 'unsafeCoerce',--- but doing so probably worsens performance, as it hampers optimizations.--- Once GHC 8.10 rolls out, I will benchmark and compare.-untag = hoistSem $ \u -> case decompCoerce u of-  Right (Weaving (Tagged e) s wv ex ins) ->-    Union SZ (Weaving e s (untag . wv) ex ins)-  Left g -> hoist untag g-{-# INLINE untag #-}----------------------------------------------------------------------------------- | Transform a @'Tagged' k1 e@ effect into a @'Tagged' k2 e@ effect-retag :: forall k1 k2 e r a-       . Member (Tagged k2 e) r-      => Sem (Tagged k1 e ': r) a-      -> Sem r a-retag = hoistSem $ \u -> case decomp u of-  Right (Weaving (Tagged e) s wv ex ins) ->-    injWeaving $ Weaving (Tagged e) s (retag . wv) ex ins-  Left g -> hoist retag g-{-# INLINE retag #-}-

@@ -1,6 +1,8 @@+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-} + module ConstraintAbsorberSpec where  import           Polysemy@@ -13,14 +15,17 @@ import           Polysemy.ConstraintAbsorber.MonadState import           Polysemy.ConstraintAbsorber.MonadWriter import           Polysemy.ConstraintAbsorber.MonadError+import           Polysemy.ConstraintAbsorber.MonadCatch  import           Test.Hspec-import           Control.Monad                 as M+import qualified Control.Monad                 as M+import           Data.Maybe                     ( fromMaybe )  import qualified Control.Monad.Reader.Class    as S import qualified Control.Monad.Writer.Class    as S import qualified Control.Monad.State.Class     as S import qualified Control.Monad.Error.Class     as S+import qualified Control.Monad.Catch           as S   {-@@ -46,6 +51,23 @@   M.when (n == 0) $ S.throwError "Zero!"   return n +data MyException = ZeroException | NegativeException | UnknownException deriving (Show, Eq)++instance S.Exception MyException++-- a different error handling option+throwOnZeroAndNegative :: S.MonadThrow m => Int -> m Int+throwOnZeroAndNegative n = do+  M.when (n == 0) $ S.throwM ZeroException+  M.when (n < 0) $ S.throwM NegativeException+  return n++-- this is dumb but it makes the point. +handleZero :: S.MonadThrow m => MyException -> m Int+handleZero ZeroException = return 0+handleZero e             = S.throwM e++ someOfAll   :: (S.MonadReader String m, S.MonadWriter [Int] m, S.MonadState Int m)   => m String@@ -93,8 +115,42 @@       modify (\m -> m - (n `div` 2))       return () +  it "should return (Right 1)." $ do+    flip shouldBe (Right 1) . run . runError $ absorbError $ throwOnZero 1   it "should return (Left \"Zero!\")." $ do     flip shouldBe (Left "Zero!") . run . runError $ absorbError $ throwOnZero 0++  let toMyException = fromMaybe UnknownException+  it "should return (Right 1)." $ do+    flip shouldBe (Right 1)+      . run+      . runMonadCatch toMyException+      $ absorbMonadThrow+      $ throwOnZeroAndNegative 1+  it "should return (Left ZeroException)." $ do+    flip shouldBe (Left ZeroException)+      . run+      . runMonadCatch toMyException+      $ absorbMonadThrow+      $ throwOnZeroAndNegative 0+  it "should return (Left \"ZeroException\")." $ do+    flip shouldBe (Left "ZeroException")+      . run+      . runMonadCatchAsText+      $ absorbMonadThrow+      $ throwOnZeroAndNegative 0+  it "should return (Right 0)." $ do+    flip shouldBe (Right 0)+      . run+      . runMonadCatch toMyException+      $ absorbMonadCatch+      $ S.catch (throwOnZeroAndNegative 0) handleZero+  it "should return (Left NegativeException)." $ do+    flip shouldBe (Left NegativeException)+      . run+      . runMonadCatch toMyException+      $ absorbMonadCatch+      $ S.catch (throwOnZeroAndNegative (-1)) handleZero    let runRWS         :: String