diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for polysemy-zoo + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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.) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/polysemy-zoo.cabal b/polysemy-zoo.cabal new file mode 100644 --- /dev/null +++ b/polysemy-zoo.cabal @@ -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 +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 diff --git a/src/Polysemy/KVStore.hs b/src/Polysemy/KVStore.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/KVStore.hs @@ -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 #-} + diff --git a/src/Polysemy/Operators.hs b/src/Polysemy/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Operators.hs @@ -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 diff --git a/test/KVStoreSpec.hs b/test/KVStoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/KVStoreSpec.hs @@ -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 + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}