polysemy-zoo (empty) → 0.1.0.0

raw patch · 9 files changed

+465/−0 lines, 9 filesdep +basedep +containersdep +hspecsetup-changed

Dependencies added: base, containers, hspec, polysemy, polysemy-plugin, polysemy-zoo

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +22/−0
• Setup.hs +2/−0
• polysemy-zoo.cabal +64/−0
• src/Polysemy/KVStore.hs +57/−0
• src/Polysemy/Operators.hs +260/−0
• test/KVStoreSpec.hs +26/−0
• test/Main.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for polysemy-zoo++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2019++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.++    * 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.++    * Neither the name of Sandy Maguire nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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.

@@ -0,0 +1,22 @@+# polysemy-zoo++[![Build Status](https://api.travis-ci.org/isovector/polysemy-zoo.svg?branch=master)](https://travis-ci.org/isovector/polysemy-zoo)+[![Hackage](https://img.shields.io/hackage/v/polysemy-zoo.svg?logo=haskell)](https://hackage.haskell.org/package/polysemy-zoo)++## Dedication++> Once I was chased by the king of all scorpions.+>+> Rachel Hunter+++## Overview++The `polysemy-zoo` is an experimental repository for user-contributed additions+to the `polysemy` ecosystem. You're encouraged to open Pull Requests here for+any effects/interpretations that you write and think might be useful for others.++Particularly successful contributions here will be migrated into either+`polysemy` proper, or `polysemy-contrib` (the less experimental version of the+zoo.)+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,64 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 2d4516a720456988b36823c429a9eb061d049ee62b9cd980163ebff3062f13c3++name:           polysemy-zoo+version:        0.1.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+homepage:       https://github.com/isovector/polysemy-zoo#readme+bug-reports:    https://github.com/isovector/polysemy-zoo/issues+author:         Sandy Maguire+maintainer:     sandy@sandymaguire.me+copyright:      2019 Sandy Maguire+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/isovector/polysemy-zoo++library+  exposed-modules:+      Polysemy.KVStore+      Polysemy.Operators+  other-modules:+      Paths_polysemy_zoo+  hs-source-dirs:+      src+  default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+  ghc-options: -fplugin=Polysemy.Plugin+  build-depends:+      base >=4.7 && <5+    , containers+    , polysemy+    , polysemy-plugin+  default-language: Haskell2010++test-suite polysemy-zoo-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      KVStoreSpec+      Paths_polysemy_zoo+  hs-source-dirs:+      test+  default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+  ghc-options: -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers+    , hspec+    , polysemy+    , polysemy-plugin+    , polysemy-zoo+  default-language: Haskell2010

@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.KVStore+  ( -- * Effect+    KVStore (..)++    -- * Actions+  , lookupKV+  , writeKV+  , deleteKV+  , updateKV++    -- * Interpretations+  , runKVStoreAsState+  , runKVStorePurely+  ) where++import qualified Data.Map as M+import           Polysemy+import           Polysemy.State+++------------------------------------------------------------------------------+-- | Models things like Redis, HTTP GET/POST, etc. Things that are keyed, have+-- a value, and may or may not be there.+data KVStore k v m a where+  LookupKV :: k -> KVStore k v m (Maybe v)+  UpdateKV :: k -> Maybe v -> KVStore k v m ()++makeSem ''KVStore+++writeKV :: Member (KVStore k v) r => k -> v -> Sem r ()+writeKV k = updateKV k . Just+{-# INLINE writeKV #-}+++deleteKV :: Member (KVStore k v) r => k -> Sem r ()+deleteKV k = updateKV k Nothing+{-# INLINE deleteKV #-}+++runKVStoreAsState :: Ord k => Sem (KVStore k v ': r) a -> Sem (State (M.Map k v) ': r) a+runKVStoreAsState = reinterpret $ \case+  LookupKV k   -> gets $ M.lookup k+  UpdateKV k v -> modify $ M.alter (const v) k+{-# INLINE runKVStoreAsState #-}+++runKVStorePurely+    :: Ord k+    => M.Map k v+    -> Sem (KVStore k v ': r) a+    -> Sem r (M.Map k v, a)+runKVStorePurely m = runState m . runKVStoreAsState+{-# INLINE runKVStorePurely #-}+

@@ -0,0 +1,260 @@+{-|++Operators meant as replacements for traditional 'Sem' type and 'Member' /+'Members' constraints, that allow you to specify types of your actions and+interpreters in more concise way, e.g. without mentioning unnecessary+details:++@+foo :: 'Member' ('Lift' 'IO') r => 'String' -> 'Int' -> 'Sem' r ()+@++can be written simply as:++@+foo :: 'String' -> 'Int' -> 'IO' '~@>' ()+@++Working example with operators:++@+import Data.Function+import Polysemy+import Polysemy.Operators+import Polysemy.Random++data ConsoleIO m a where+  WriteStrLn ::           'String' -> ConsoleIO m ()+  ReadStrLn  ::                     ConsoleIO m 'String'+  ShowStrLn  :: 'Show' a => a      -> ConsoleIO m ()++'makeSem' ''ConsoleIO++-- runConsoleIO :: Member (Lift IO) r => Sem (ConsoleIO:r) a -> Sem r a+runConsoleIO :: ConsoleIO:r '@>' a -> 'IO' '~@' r '@>' a+runConsoleIO = 'interpret' \\case+  WriteStrLn s -> 'sendM' '$' 'putStrLn' s+  ReadStrLn    -> 'sendM'   'getLine'+  ShowStrLn  v -> 'sendM' '$' 'print' v++main :: 'IO' ()+main = program+     'Data.Function.&' runConsoleIO+     'Data.Function.&' 'Polysemy.Random.runRandomIO'+     'Data.Function.&' 'runM'++-- program :: Members \'[Random, ConsoleIO] r => Sem r ()+program :: \'['Polysemy.Random', ConsoleIO] '>@>' ()+program = do+  writeStrLn "It works! Write something:"+  val <- readStrLn+  writeStrLn '$' "Here it is!: " '++' val+  num <- 'Polysemy.Random.random' \@'Int'+  writeStrLn '$' "Some random number:"+  showStrLn num+@++See documentation of specific operators for more details.++-}++module Polysemy.Operators+  ( -- * 'Sem' operators+    type (@>)+  , type (@-)+  , type (@~)+    -- $SemOperators++  , -- * 'Member' operators+    type (>@)+  , type (-@)+  , type (~@)+    -- $MemberOperators++  , -- * Combined operators+    type (>@>)+  , type (-@>)+  , type (~@>)+    -- $CombinedOperators+  ) where++import Polysemy++------------------------------------------------------------------------------+-- Miscellaneous -------------------------------------------------------------+------------------------------------------------------------------------------+-- | Gets list of effects from 'Sem'.+type family SemList s where+  SemList (Sem r _) = r++------------------------------------------------------------------------------+-- Operators -----------------------------------------------------------------+------------------------------------------------------------------------------+-- $SemOperators+-- Infix equivalents of 'Sem' with versions for specifiying list of effects+-- ('@>'), single effect ('@-') and single monad ('@~') as effects of union.+-- Use ('>@>'), ('-@>') or ('~@>') instead if you are not making any+-- transformations on union and just want to use some members instead.+--+-- __Examples:__+--+-- 'Sem' with list of multiple effects:+--+-- @+-- foo :: 'Sem' ('Polysemy.State.State' 'Int' : r) ()+-- @+--+-- can be written as:+--+-- @+-- foo :: 'Polysemy.State.State' 'Int' : r '@>' ()+-- @+--+-- 'Sem' with list of one effect:+--+-- @+-- foo :: 'Sem' \'['Polysemy.State.State' 'Int'] ()+-- @+--+-- can be written as both (with the latter preferred):+--+-- @+-- foo :: \'['Polysemy.State.State' 'Int'] '@>' ()+-- @+--+-- and:+--+-- @+-- foo :: 'Polysemy.State.State' 'Int' '@-' ()+-- @+--+-- where effect without list gets put into one automatically.+--+-- 'Sem' with __exactly__ one, lifted monad:+--+-- @+-- foo :: 'Sem' \'['Lift' 'IO'] ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'IO' '@~' ()+-- @+--+-- and will be automatically lifted and put into list.+infix 2 @>, @-, @~++type (@>)   = Sem+type (@-) e = Sem '[e]+type (@~) m = Sem '[Lift m]++-- $MemberOperators+-- Infix equivalents of 'Member'(s) constraint used directly in /return/ type,+-- specifiying list of members ('>@'), single member ('-@') or single monad+-- ('~@'), meant to be paired with some of the 'Sem' operators (('@>'), ('@-')+-- and ('@~')). Use ('>@>'), ('-@>') or ('~@>') instead if you are not making+-- any transformations on union and just want to use some members instead.+--+-- __Examples:__+--+-- List of multiple members:+--+-- @+-- foo :: 'Members' \'['Polysemy.State.State' 'Int', 'Polysemy.Input.Input' 'String'] r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- @+--+-- can be written as:+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> \'['Polysemy.State.State' 'Int', 'Polysemy.Input.Input' 'String'] '>@' r '@>' ()+-- @+--+-- One member:+--+-- @+-- foo :: 'Member' ('Polysemy.State.State' 'Int') r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- @+--+-- can be written as both (with the latter preferred):+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> \'['Polysemy.State.State' 'Int'] '>@' r '@>' ()+-- @+--+-- and:+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> 'Polysemy.State.State' 'Int' '-@' r '@>' ()+-- @+--+-- __Exactly__ one, lifted monad as a member:+--+-- @+-- foo :: 'Member' ('Lift' 'IO') r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> 'IO' '~@' r '@>' ()+-- @+infix 1 >@, -@, ~@++type (>@) es s = Members es       (SemList s) => s+type (-@) e  s = Member  e        (SemList s) => s+type (~@) m  s = Member  (Lift m) (SemList s) => s++-- $CombinedOperators+-- Joined versions of one of ('>@'), ('-@'), ('~@') and ('@>') with implicit,+-- hidden list of effects in union --- suited for actions that only use one+-- 'Sem' in their type.+--+-- __Examples:__+--+-- List of members over some 'Sem':+--+-- @+-- foo :: 'Members' \'['Polysemy.State.State' 'String', 'Polysemy.Input.Input' 'Int'] r => 'String' -> 'Int' -> 'Sem' r ()+-- @+--+-- can be written as:+--+-- @+-- foo :: 'String' -> 'Int' -> \'['Polysemy.State.State' 'String', 'Polysemy.Input.Input' 'Int'] '>@>' ()+-- @+--+-- Single member:+--+-- @+-- foo :: 'Member' ('Polysemy.Input.Input' 'Int') r => 'String' -> 'Int' -> 'Sem' r ()+-- @+--+-- can be written as both (with the latter preferred):+--+-- @+-- foo :: 'String' -> 'Int' -> \'['Polysemy.Input.Input' 'Int'] '>@>' ()+-- @+--+-- and:+--+-- @+-- foo :: 'String' -> 'Int' -> 'Polysemy.Input.Input' 'Int' '-@>' ()+-- @+--+-- __Exactly__ one, lifted monad as a member:+--+-- @+-- foo :: 'Member' ('Lift' 'IO') r => 'Sem' r ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'IO' '~@>' ()+-- @+infix 1 >@>, -@>, ~@>++type (>@>) es a = forall r. Members es       r => Sem r a+type (-@>) e  a = forall r. Member  e        r => Sem r a+type (~@>) m  a = forall r. Member  (Lift m) r => Sem r a

@@ -0,0 +1,26 @@+module KVStoreSpec where++import qualified Data.Map as M+import           Polysemy+import           Polysemy.KVStore+import           Test.Hspec+++program :: Member (KVStore Bool Int) r => Sem r (Maybe Int)+program = do+  a <- lookupKV False+  b <- lookupKV True+  pure $ (+) <$> a <*> b+++spec :: Spec+spec = do+  describe "KVStore" $ do+    let itShouldBe m v = run (fmap snd $ runKVStorePurely (M.fromList m) program) `shouldBe` v++    it "should fail to find missing keys" $ do+      itShouldBe [] Nothing++    it "should add if all the keys are there" $ do+      itShouldBe [(False, 5), (True, 10)] $ Just 15+

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}