polysemy-extra 0.1.7.0 → 0.2.0.0

raw patch · 3 files changed

+146/−198 lines, 3 filesdep +polysemy-kvstoredep −exceptionsdep −extradep −polysemy-zoodep ~containersdep ~polysemyPVP ok

version bump matches the API change (PVP)

Dependencies added: polysemy-kvstore

Dependencies removed: exceptions, extra, polysemy-zoo

Dependency ranges changed: containers, polysemy

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• polysemy-extra.cabal +6/−8
• src/Polysemy/Extra.hs +135/−190

@@ -1,5 +1,10 @@ # Changelog for polysemy-extra +## v0.2.0.0++* Remove `runKVStoreAsKVStore` and `runKVStoreAsKVStoreSem` and move to `polysemy-kvstore`.+* Remove `irrefutableAbsorbThrow` and move to `polysemy-irrefutable-absorb-throw`.+ ## v0.1.7.0  * Add `irrefutableAbsorbThrow`.

@@ -1,12 +1,12 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.2.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           polysemy-extra-version:        0.1.7.0-synopsis:       Extra Input and Output functions for polysemy..+version:        0.2.0.0+synopsis:       Extra Input and Output functions for polysemy. category:       Polysemy author:         Daniel Firth maintainer:     dan.firth@homotopic.tech@@ -32,9 +32,7 @@   ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints   build-depends:       base >=4.7 && <5-    , containers-    , exceptions-    , extra-    , polysemy >=1.4.0.0-    , polysemy-zoo+    , containers >=0.4.0.0 && <0.7+    , polysemy >=1.4.0.0 && <1.7+    , polysemy-kvstore >=0.1.2.0 && <0.2   default-language: Haskell2010

@@ -1,124 +1,73 @@-{-|-Module      : Polysemy.Extra-License     : MIT-Maintainer  : dan.firth@homotopic.tech-Stability   : experimental--Extra convenience functions for polysemy.--} {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BlockArguments      #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}-module Polysemy.Extra (--- * Input-  contramapInput-, contramapInputSem-, contramapInput'-, runInputConstF---- * Output-, mapOutput-, mapOutputSem-, mapOutput'-, runOutputMapAsKVStore+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-} --- * KVStore-, runKVStoreAsKVStore-, runKVStoreAsKVStoreSem+-- |+-- Module      : Polysemy.Extra+-- License     : MIT+-- Maintainer  : dan.firth@homotopic.tech+-- Stability   : experimental+--+-- Extra convenience functions for polysemy.+module Polysemy.Extra+  ( -- * Input+    contramapInput,+    contramapInputSem,+    contramapInput',+    runInputConstF, --- * Raise-, raise4Under+    -- * Output+    mapOutput,+    mapOutputSem,+    mapOutput',+    runOutputMapAsKVStore, --- * Reinterpreters-, reinterpretUnder-, reinterpretUnder2-, reinterpret2Under+    -- * Raise+    raise4Under, --- * Rotation-, rotateEffects2-, rotateEffects3L-, rotateEffects3R-, rotateEffects4L-, rotateEffects4R+    -- * Reinterpreters+    reinterpretUnder,+    reinterpretUnder2,+    reinterpret2Under, --- * Reverse-, reverseEffects2-, reverseEffects3-, reverseEffects4+    -- * Rotation+    rotateEffects2,+    rotateEffects3L,+    rotateEffects3R,+    rotateEffects4L,+    rotateEffects4R, --- * Exceptions-, irrefutableAbsorbThrow-) where+    -- * Reverse+    reverseEffects2,+    reverseEffects3,+    reverseEffects4,+  )+where  import Control.Arrow-import Control.Monad-import qualified Control.Monad.Catch as C-import Control.Monad.Extra import Data.Map as Map import Polysemy-import Polysemy.ConstraintAbsorber.MonadCatch-import Polysemy.Error-import Polysemy.KVStore import Polysemy.Input-import Polysemy.Output-import Polysemy.Membership import Polysemy.Internal import Polysemy.Internal.Union---- | Run a `KVStore` in terms of another `KVStore` by way of pure key and value--- transformations.------ @since 0.1.0.0-runKVStoreAsKVStore :: forall k v k' v' r a.-                       (k  -> k')-                       -- ^ A function to transform the key into the interpreted key.-                    -> (v  -> v')-                       -- ^ A function to transform the value into the interpreted value.-                    -> (v' -> v )-                       -- ^ A function to transform the interpreted key back into the current value.-                    -> Sem (KVStore k v ': r) a-                    -> Sem (KVStore k' v' ': r) a-runKVStoreAsKVStore f g h = reinterpret \case-  LookupKV k   -> fmap h <$> lookupKV @k' @v' (f k)-  UpdateKV k x -> updateKV @k' @v' (f k) (fmap g x)-{-# INLINE runKVStoreAsKVStore #-}---- | Run a `KVStore` in terms of another `KVStore` by way of transforming the--- keys and values with Sem functions.------ @since 0.1.0.0-runKVStoreAsKVStoreSem :: forall k v k' v' r a.-                          Members '[KVStore k' v'] r-                       => (k  -> Sem r k')-                          -- ^ A function to transform the key into the interpreted key.-                       -> (v  -> Sem r v')-                          -- ^ A function to transform the value into the interpreted value.-                       -> (v' -> Sem r v )-                          -- ^ A function to transform the interpreted value back into the current value.-                       -> Sem (KVStore k v ': r) a-                       -> Sem r a-runKVStoreAsKVStoreSem f g h = interpret \case-  LookupKV k   -> f k >>= lookupKV @k' @v' >>= mapM h-  UpdateKV k x -> do-    z  <- f k-    z' <- mapM g x-    updateKV @k' @v' z z'-{-# INLINE runKVStoreAsKVStoreSem #-}+import Polysemy.KVStore+import Polysemy.Output  -- | Run an `Output` (`Map` k v) as a `KVStore` by writing the values to -- the keys. -- -- @since 0.1.0.0-runOutputMapAsKVStore :: Members '[ KVStore k v ] r-                      => Sem (Output (Map k v) ': r) a-                      -> Sem r a+runOutputMapAsKVStore ::+  Members '[KVStore k v] r =>+  Sem (Output (Map k v) ': r) a ->+  Sem r a runOutputMapAsKVStore = interpret \case   Output xs -> mapM_ (uncurry writeKV) (Map.toList xs) {-# INLINE runOutputMapAsKVStore #-}@@ -126,11 +75,12 @@ -- | Map an `Output` covariantly. -- -- @since 0.1.0.0-mapOutput :: Members '[ Output o' ] r-          => (o -> o')-             -- ^ A function to map the old output to the new output.-          -> Sem (Output o ': r) a-          -> Sem r a+mapOutput ::+  Members '[Output o'] r =>+  -- | A function to map the old output to the new output.+  (o -> o') ->+  Sem (Output o ': r) a ->+  Sem r a mapOutput f = interpret \case   Output o -> output (f o) {-# INLINE mapOutput #-}@@ -138,23 +88,25 @@ -- | Reinterpreting version of `mapOutput`. -- -- @since 0.1.4.0-mapOutput' :: Members '[ Output o' ] r-           => (o -> o')-              -- ^ A function to map the old output to the new output.-           -> Sem (Output o  ': r) a-           -> Sem (Output o' ': r) a+mapOutput' ::+  Members '[Output o'] r =>+  -- | A function to map the old output to the new output.+  (o -> o') ->+  Sem (Output o ': r) a ->+  Sem (Output o' ': r) a mapOutput' f = raiseUnder >>> mapOutput f {-# INLINE mapOutput' #-}  -- | Map an `Output` covariantly through a monadic function. -- -- @since 0.1.0.0-mapOutputSem :: forall o o' r a.-                Members '[ Output o' ] r-             => (o -> Sem r o')-                -- ^ A function to map the old output to the new output.-             -> Sem (Output o ': r) a-             -> Sem r a+mapOutputSem ::+  forall o o' r a.+  Members '[Output o'] r =>+  -- | A function to map the old output to the new output.+  (o -> Sem r o') ->+  Sem (Output o ': r) a ->+  Sem r a mapOutputSem f = interpret \case   Output o -> f o >>= output {-# INLINE mapOutputSem #-}@@ -162,12 +114,13 @@ -- | Map an `Input` contravariantly. -- -- @since 0.1.0.0-contramapInput :: forall i i' r a.-                  Members '[ Input i' ] r-               => (i' -> i)-                  -- ^ A function to map the new input to the old input.-               -> Sem (Input i ': r) a-               -> Sem r a+contramapInput ::+  forall i i' r a.+  Members '[Input i'] r =>+  -- | A function to map the new input to the old input.+  (i' -> i) ->+  Sem (Input i ': r) a ->+  Sem r a contramapInput f = interpret \case   Input -> f <$> input @i' {-# INLINE contramapInput #-}@@ -175,23 +128,25 @@ -- | Reinterpreting version of `contramapInput`. -- -- @since 0.1.4.0-contramapInput' :: forall i i' r a.-                   Members '[ Input i' ] r-               => (i' -> i)-                  -- ^ A function to map the new input to the old input.-               -> Sem (Input i  ': r) a-               -> Sem (Input i' ': r) a+contramapInput' ::+  forall i i' r a.+  Members '[Input i'] r =>+  -- | A function to map the new input to the old input.+  (i' -> i) ->+  Sem (Input i ': r) a ->+  Sem (Input i' ': r) a contramapInput' f = raiseUnder >>> contramapInput f {-# INLINE contramapInput' #-}  -- | Map an `Input` contravariantly through a monadic function. -- @since 0.1.0.0-contramapInputSem :: forall i i' r a.-                     Members '[ Input i' ] r-                  => (i' -> Sem r i)-                     -- ^ A function to map the new input to the old input.-                  -> Sem (Input i ': r) a-                  -> Sem r a+contramapInputSem ::+  forall i i' r a.+  Members '[Input i'] r =>+  -- | A function to map the new input to the old input.+  (i' -> Sem r i) ->+  Sem (Input i ': r) a ->+  Sem r a contramapInputSem f = interpret \case   Input -> f =<< input @i' {-# INLINE contramapInputSem #-}@@ -199,60 +154,67 @@ -- | Like `runInputConst`, except with a type parameter for the functor for abusing type applications. -- -- @since 0.1.5.0-runInputConstF :: forall b f r a.-                  f b-               -> Sem (Input (f b) ': r) a-               -> Sem r a+runInputConstF ::+  forall b f r a.+  f b ->+  Sem (Input (f b) ': r) a ->+  Sem r a runInputConstF = runInputConst @(f b) {-# INLINE runInputConstF #-}  -- | Reinterpret the second effect in the stack into a single effect. -- -- @since 0.1.1.0-reinterpretUnder :: forall e1 e2 e3 r a.-                    (forall m x. Sem (e2 ': m) x -> Sem (e3 ': m) x)-                    -- ^ A natural transformation from the handled effect to the new effects.-                 -> Sem (e1 ': e2 ': r) a-                 -> Sem (e1 ': e3 ': r) a-reinterpretUnder f = raise2Under @e1 @e1 @e2-                 >>> subsumeUsing @e1 (There Here)-                 >>> f-                 >>> raise2Under @e3 @e3 @e1-                 >>> subsumeUsing @e3 (There Here)+reinterpretUnder ::+  forall e1 e2 e3 r a.+  -- | A natural transformation from the handled effect to the new effects.+  (forall m x. Sem (e2 ': m) x -> Sem (e3 ': m) x) ->+  Sem (e1 ': e2 ': r) a ->+  Sem (e1 ': e3 ': r) a+reinterpretUnder f =+  raise2Under @e1 @e1 @e2+    >>> subsumeUsing @e1 (There Here)+    >>> f+    >>> raise2Under @e3 @e3 @e1+    >>> subsumeUsing @e3 (There Here) {-# INLINE reinterpretUnder #-}  -- | Reinterpret the third effect in the stack into a single effect. -- -- @since 0.1.1.0-reinterpretUnder2 :: forall e1 e2 e3 e4 r a.-                     (forall m x. Sem (e3 ': m) x -> Sem (e4 ': m) x)-                     -- ^ A natural transformation from the handled effect to the new effects.-                  -> Sem (e1 ': e2 ': e3 ': r) a-                  -> Sem (e1 ': e2 ': e4 ': r) a-reinterpretUnder2 f = raise3Under @e1 @e1 @e2 @e3-                  >>> subsumeUsing @e1 (There $ There Here)-                  >>> raise3Under @e2 @e2 @e3 @e1-                  >>> subsumeUsing @e2 (There $ There Here)-                  >>> f-                  >>> raise3Under @e4 @e4 @e1 @e2-                  >>> subsumeUsing @e4 (There $ There Here)+reinterpretUnder2 ::+  forall e1 e2 e3 e4 r a.+  -- | A natural transformation from the handled effect to the new effects.+  (forall m x. Sem (e3 ': m) x -> Sem (e4 ': m) x) ->+  Sem (e1 ': e2 ': e3 ': r) a ->+  Sem (e1 ': e2 ': e4 ': r) a+reinterpretUnder2 f =+  raise3Under @e1 @e1 @e2 @e3+    >>> subsumeUsing @e1 (There $ There Here)+    >>> raise3Under @e2 @e2 @e3 @e1+    >>> subsumeUsing @e2 (There $ There Here)+    >>> f+    >>> raise3Under @e4 @e4 @e1 @e2+    >>> subsumeUsing @e4 (There $ There Here) {-# INLINE reinterpretUnder2 #-}  -- | Reinterpret the second effect in the stack in terms of two effects. -- -- @since 0.1.1.0-reinterpret2Under :: forall e1 e2 e3 e4 r a.-                     (forall m x. Sem (e2 ': m) x -> Sem (e3 ': e4 ': m) x)-                     -- ^ A natural transformation from the handled effect to the new effects.-                  -> Sem (e1 ': e2 ': r) a-                  -> Sem (e1 ': e3 ': e4 ': r) a-reinterpret2Under f = raise2Under @e1 @e1 @e2-                  >>> subsumeUsing @e1 (There Here)-                  >>> f-                  >>> raise3Under @e3 @e3 @e4 @e1-                  >>> subsumeUsing @e3 (There $ There Here)-                  >>> raise3Under @e4 @e4 @e1 @e3-                  >>> subsumeUsing @e4 (There $ There Here)+reinterpret2Under ::+  forall e1 e2 e3 e4 r a.+  -- | A natural transformation from the handled effect to the new effects.+  (forall m x. Sem (e2 ': m) x -> Sem (e3 ': e4 ': m) x) ->+  Sem (e1 ': e2 ': r) a ->+  Sem (e1 ': e3 ': e4 ': r) a+reinterpret2Under f =+  raise2Under @e1 @e1 @e2+    >>> subsumeUsing @e1 (There Here)+    >>> f+    >>> raise3Under @e3 @e3 @e4 @e1+    >>> subsumeUsing @e3 (There $ There Here)+    >>> raise3Under @e4 @e4 @e1 @e3+    >>> subsumeUsing @e4 (There $ There Here) {-# INLINE reinterpret2Under #-}  -- | Like `raise`, but introduces an effect four levels underneath the head of the list.@@ -325,20 +287,3 @@ reverseEffects4 :: forall e1 e2 e3 e4 r a. Sem (e1 ': e2 ': e3 ': e4 ': r) a -> Sem (e4 ': e3 ': e2 ': e1 ': r) a reverseEffects4 = rotateEffects4L >>> rotateEffects3L >>> rotateEffects2 {-# INLINE reverseEffects4 #-}---- | Irrefutably absorb a `MonadThrow` constraint as a particular `Exception` type.---  This is useful for translating functions that you know use only use---  one error type. For more complicated uses of `MonadThrow` it's---  probably best to just rewrite the function in terms of `Sem`.--- ------ @since 0.1.7.0-irrefutableAbsorbThrow :: forall e r a. (Exception e, Members '[Error e] r)-                       => (forall m.  C.MonadThrow m => m a)-                       -> Sem r a-irrefutableAbsorbThrow f = do-  k <- runError (absorbMonadThrow f)-  either (p >=> throw @e) return k-    where p x = fromMaybeM-                  (error $ "Irrefutable Cast:  " <> show x)-                  (return $ C.fromException x)