diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for polysemy-extra +## v0.1.2.0 + +* Add `rotateEffects2`, `rotateEffects3L` and `rotateEffects3R`. + ## v0.1.1.0 * Add `reinterpretUnder`, `reinterpretUnder2` and `reinterpret2Under`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,19 @@ -Copyright Daniel Firth (c) 2020 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +Copyright (c) 2020 Daniel Firth - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/polysemy-extra.cabal b/polysemy-extra.cabal --- a/polysemy-extra.cabal +++ b/polysemy-extra.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: polysemy-extra -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Extra Input and Output functions for polysemy.. category: Polysemy author: Daniel Firth diff --git a/src/Polysemy/Extra.hs b/src/Polysemy/Extra.hs --- a/src/Polysemy/Extra.hs +++ b/src/Polysemy/Extra.hs @@ -1,14 +1,45 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PolyKinds #-} +{-| +Module : Polysemy.Extra +License : MIT +Maintainer : dan.firth@homotopic.tech +Stability : experimental + +Extra convenience functions for polysemy. +-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -module Polysemy.Extra where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Polysemy.Extra ( +-- * Input + contramapInput +, contramapInputSem +-- * Output +, mapOutput +, mapOutputSem +, runOutputMapAsKVStore + +-- * KVStore +, runKVStoreAsKVStore +, runKVStoreAsKVStoreSem + +-- * Combinatorial Reinterpreters +, reinterpretUnder +, reinterpretUnder2 +, reinterpret2Under + +-- * Rotation +, rotateEffects2 +, rotateEffects3L +, rotateEffects3R +) where + import Control.Arrow import Data.Map as Map import Polysemy @@ -17,25 +48,35 @@ import Polysemy.Output import Polysemy.Membership --- | Run a KVStore in terms of another KVStore by way of pure key and value +-- | 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) --- | Run a KVStore in terms of another KVStore by way of transforming the +-- | 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 @@ -45,51 +86,67 @@ z' <- mapM g x updateKV @k' @v' z z' --- | Run an `Output (Map k v)` as a `KVStore` by writing the values to +-- | 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 = interpret \case Output xs -> mapM_ (uncurry writeKV) (Map.toList xs) --- | Map an Output forwards +-- | 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 f = interpret \case Output o -> output (f o) --- | Map an Output forwards through a monadic function. +-- | Map an `Output` covariantly through a monadic function. +-- +-- @since 0.1.0.0 mapOutputSem :: 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 f = interpret \case Output o -> f o >>= output -- | 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 f = interpret \case Input -> f <$> input @i' -- | 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 f = interpret \case Input -> f =<< input @i' -- | 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 @@ -99,8 +156,11 @@ >>> subsumeUsing @e3 (There Here) -- | 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 @@ -112,8 +172,11 @@ >>> subsumeUsing @e4 (There $ There Here) -- | 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 @@ -123,3 +186,21 @@ >>> subsumeUsing @e3 (There $ There Here) >>> raise3Under @e4 @e4 @e1 @e3 >>> subsumeUsing @e4 (There $ There Here) + +-- | Swap the positions of the first two effects in the stack. +-- +-- @since 0.1.2.0 +rotateEffects2 :: forall e1 e2 r a. Sem (e1 ': e2 ': r) a -> Sem (e2 ': e1 ': r) a +rotateEffects2 = raise2Under >>> subsumeUsing (There Here) + +-- | Rotate the first three effects in the stack to the left. +-- +-- @since 0.1.2.0 +rotateEffects3L :: forall e1 e2 e3 r a. Sem (e1 ': e2 ': e3 ': r) a -> Sem (e2 ': e3 ': e1 ': r) a +rotateEffects3L = raise3Under >>> subsumeUsing (There $ There Here) + +-- | Rotate the first three effects in the stack to the right. +-- +-- @since 0.1.2.0 +rotateEffects3R :: forall e1 e2 e3 r a. Sem (e1 ': e2 ': e3 ': r) a -> Sem (e3 ': e1 ': e2 ': r) a +rotateEffects3R = rotateEffects3L >>> rotateEffects3L