packages feed

polysemy-keyed-state (empty) → 0.1

raw patch · 7 files changed

+512/−0 lines, 7 filesdep +QuickCheckdep +StateVardep +base

Dependencies added: QuickCheck, StateVar, base, constraints, constraints-extras, hspec, polysemy, some, trivial-constraint

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.1+---+Initial release.
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2021 Katie Casamento++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,19 @@+# polysemy-keyed-state++![build/test](https://github.com/kcsmnt0/polysemy-keyed-state/actions/workflows/haskell.yml/badge.svg)++This package provides the `KeyedState` effect for use with [`polysemy`](https://hackage.haskell.org/package/polysemy). For any key type `k :: Type -> Type`, the `KeyedState k` effect provides access to a set of stateful values indexed by `k`, where a key of type `k a` can be used to access a stateful value of type `a`.++In the most direct use case, the `KeyedState` effect can be used as an interface to low-level reference types like `IORef` and `STRef`: for example, `getAt` can be used with the type `Member (KeyedState IORef) r => IORef a -> Sem r a`.++At a higher level, key types defined as GADTs can be used with `KeyedState` to represent sets of stateful variables in a single effect. For example, with the GADT definition of `K` below, the effect `KeyedState K` provides access to an `Int` value with key `X` and a `Bool` value with key `Y`.++```haskell+data K a where+  X :: K Int+  Y :: K Bool+```++By mapping high-level keys to low-level references, the `KeyedState` effect can be used to implement a high-level interface to a set of low-level variables.++Some of the interpreters for `KeyedState` require instances of `Has` for certain typeclasses, which can be generated for most GADT key types with `deriveArgDict` from the [`constraints-extras`](https://hackage.haskell.org/package/constraints-extras) package.
+ polysemy-keyed-state.cabal view
@@ -0,0 +1,105 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           polysemy-keyed-state+version:        0.1+synopsis:       Effect for a set of stateful values indexed by a type of keys+description:    The @KeyedState k@ effect provides access to a set of stateful values indexed by some key type @k :: Type -> Type@, where a key of type @k a@ can be used to access a stateful value of type @a@.+category:       BSD3, Library+homepage:       https://github.com/kcsmnt0/polysemy-keyed-state#readme+bug-reports:    https://github.com/kcsmnt0/polysemy-keyed-state/issues+maintainer:     Katie Casamento <kcsmnt0@gmail.com>+license:        BSD3+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 8.10.5+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/kcsmnt0/polysemy-keyed-state++library+  exposed-modules:+      Polysemy.State.Keyed+      Polysemy.State.Keyed.Law+  other-modules:+      Paths_polysemy_keyed_state+  hs-source-dirs:+      src+  default-extensions:+      AllowAmbiguousTypes+      ConstraintKinds+      DataKinds+      FlexibleContexts+      FlexibleInstances+      GADTs+      LambdaCase+      MultiParamTypeClasses+      QuantifiedConstraints+      RankNTypes+      ScopedTypeVariables+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+  ghc-options: -Wall -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields+  build-depends:+      StateVar ==1.2.*+    , base >=4.12 && <4.15+    , constraints >=0.11 && <0.14+    , constraints-extras >=0.3.0.2 && <0.4+    , polysemy >=1.3 && <1.6+    , some >=1.0.1 && <1.1+    , trivial-constraint >=0.3 && <0.8+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Polysemy.State.Keyed+      Polysemy.State.Keyed.Law+      Paths_polysemy_keyed_state+  hs-source-dirs:+      src+      test+  default-extensions:+      AllowAmbiguousTypes+      ConstraintKinds+      DataKinds+      FlexibleContexts+      FlexibleInstances+      GADTs+      LambdaCase+      MultiParamTypeClasses+      QuantifiedConstraints+      RankNTypes+      ScopedTypeVariables+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      StandaloneDeriving+  ghc-options: -Wall -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -threaded+  build-depends:+      QuickCheck >=2.11.3 && <2.15+    , StateVar ==1.2.*+    , base >=4.12 && <4.15+    , constraints >=0.11 && <0.14+    , constraints-extras >=0.3.0.2 && <0.4+    , hspec >=2.4.7 && <2.9+    , polysemy >=1.3 && <1.6+    , some >=1.0.1 && <1.1+    , trivial-constraint >=0.3 && <0.8+  default-language: Haskell2010
+ src/Polysemy/State/Keyed.hs view
@@ -0,0 +1,236 @@+module Polysemy.State.Keyed+  ( KeyedState(..)+  -- * Operations+  , getAt+  , putAt+  , modifyAt+  , rename+  -- * @State@ interpreters+  , runKeyedStates+  , KeyedStore(..)+  , lookupAt, updateAt, updateAtBy+  , runKeyedStateStore, runKeyedStateStoreBy+  -- * @IO@ interpreters+  , Reference, module Data.Constraint.Trivial+  , runKeyedStateRefsIO+  , runKeyedStateVarsIO, runKeyedStateVarsOfIO+  , runStorableKeyedStateVarsIO, runStorableKeyedStateVarsOfIO+  , runConstrainedKeyedStateVarsIO, runConstrainedKeyedStateVarsOfIO+  )+  where++import Data.Constraint+import Data.Constraint.Extras+import Data.Constraint.Trivial+import Data.StateVar hiding (get)+import qualified Data.StateVar as StateVar+import Data.Typeable+import Foreign.Storable+import Polysemy+import Polysemy.Input+import Polysemy.Internal+import Polysemy.Membership+import Polysemy.State++newtype UnconstrainedKey k a = UnconstrainedKey { getUnconstrainedKey :: k a }+instance ArgDict Unconstrained (UnconstrainedKey k) where+  type ConstraintsFor (UnconstrainedKey k) Unconstrained = ()+  argDict = const Dict++{-|+An interpreter for @KeyedState@ may or may not obey the following "consistency" law:++* for any @k@, @k'@, and @v@, @putAt k v *> getAt k' = if k == k' then pure v else getAt k'@++This law is relevant for most pure interpretations of @KeyedState@, but only applies when the values in the state are /disjoint/ (setting at @k@ does not modify the value at @k'@ when @k /= k'@) and /local/ (never modified by another thread or program). Some useful sets of stateful values violate this law: for example, the [@sdl2@](https://hackage.haskell.org/package/sdl2) package provides a set of [@StateVar@s](https://hackage.haskell.org/package/StateVar/docs/Data-StateVar.html#t:StateVar) for each SDL window created, which are neither disjoint nor local.+-}+data KeyedState k :: Effect where+  GetAt :: k a -> KeyedState k m a+  PutAt :: k a -> a -> KeyedState k m ()++makeSem ''KeyedState++modifyAt ::+  forall k a r.+  Member (KeyedState k) r =>+  k a -> (a -> a) -> Sem r ()+modifyAt k f = putAt k . f =<< getAt k++-- |Run a @KeyedState@ operation in the context of another @KeyedState@ effect by translating the keys.+rename ::+  forall k k' r a.+  Member (KeyedState k') r =>+  (forall x. k x -> k' x) -> Sem (KeyedState k : r) a -> Sem r a+rename h =+  transform $ \case+    GetAt k -> GetAt $ h k+    PutAt k x -> PutAt (h k) x++{-|+Distribute a @KeyedState@ effect across multiple @State@ effects by mapping each key to an effect.++Lawful if the @State@ effects are interpreted lawfully.+-}+runKeyedStates ::+  forall k r.+  (forall a. k a -> ElemOf (State a) r) ->+  InterpreterFor (KeyedState k) r+runKeyedStates h =+  interpret $ \case+    GetAt k -> subsumeUsing (h k) get+    PutAt k x -> subsumeUsing (h k) $ put x++-- |A @KeyedStore k@ is a total map over keys of type @k@.+newtype KeyedStore k = KeyedStore { runKeyedStore :: forall a. k a -> a }++-- |Retrieve a value from a @KeyedStore@.+lookupAt :: k a -> KeyedStore k -> a+lookupAt = flip runKeyedStore++-- |Update a value in a @KeyedStore@, using @Typeable@ instances to check for key type equality.+updateAt ::+  forall k a.+  (Typeable a, Has Typeable k, forall x. Eq (k x)) =>+  k a -> a -> KeyedStore k -> KeyedStore k+updateAt = updateAtBy $ \_ k' -> has @Typeable k' eqT++-- |Update an entry in a @KeyedStore@, using a specified function to check for key type equality. This can be used with functions like [@testEquality@](https://hackage.haskell.org/package/base/docs/Data-Type-Equality.html#v:testEquality) and [@geq@](https://hackage.haskell.org/package/some/docs/Data-GADT-Compare.html#v:geq) to avoid @Typeable@ constraints.+updateAtBy ::+  forall k a.+  (forall x. Eq (k x)) =>+  (forall b. k a -> k b -> Maybe (a :~: b)) ->+  k a -> a -> KeyedStore k -> KeyedStore k+updateAtBy eq k x m =+  KeyedStore $ \k' ->+    case eq k k' of+      Just Refl | k == k' -> x+      _ -> lookupAt k' m++{-|+Interpret a @KeyedState@ effect as a @State@ effect over a @KeyedStore@, using @Typeable@ instances to check for key type equality.++Lawful.+-}+runKeyedStateStore ::+  forall k r.+  (Member (State (KeyedStore k)) r, forall a. Eq (k a), Has Typeable k) =>+  InterpreterFor (KeyedState k) r+runKeyedStateStore =+  runKeyedStateStoreBy $ \k k' ->+    has @Typeable k $ has @Typeable k' eqT++{-|+Interpret a @KeyedState@ effect as a @State@ effect over a @KeyedStore@, using a specified function to check for key type equality. This can be used with functions like [@testEquality@](https://hackage.haskell.org/package/base/docs/Data-Type-Equality.html#v:testEquality) and [@geq@](https://hackage.haskell.org/package/some/docs/Data-GADT-Compare.html#v:geq) to avoid @Typeable@ constraints.++Lawful if the key type equality function always returns @Just Refl@ whenever possible (i.e. it correctly says that any two equal types are equal); otherwise, @putAt@ may silently fail to have any effect in some cases.+-}+runKeyedStateStoreBy ::+  forall k r.+  (Member (State (KeyedStore k)) r, forall a. Eq (k a)) =>+  (forall a b. k a -> k b -> Maybe (a :~: b)) ->+  InterpreterFor (KeyedState k) r+runKeyedStateStoreBy eq =+  interpret $ \case+    GetAt k -> lookupAt k <$> get+    PutAt k x -> put . updateAtBy eq k x =<< get++-- |An instance of @Reference c k@ indicates that @k@ is an @IO@ reference type (like @IORef@, @STRef@, ...) that requires values to meet the constraint @c@. For more information, see the documentation for @HasGetter@ and @HasSetter@.+class (forall a. c a => HasGetter (k a) a, forall a. c a => HasSetter (k a) a) => Reference c k+instance (forall a. c a => HasGetter (k a) a, forall a. c a => HasSetter (k a) a) => Reference c k++{-|+Interpret each key directly as an @IO@ reference. Useful with "key" types like @IORef@ and @STRef@.+ +Note that there is no way to directly interpret a @KeyedState@ effect where the "keys" are references that require @Storable@ or other constraints to modify, like @Ptr@ and @ForeignPtr@, since @PutAt@ does not have any constraints on its argument type. To use @KeyedState@ with constrained reference types, you can define a GADT key type to represent the set of references and interpret the effect with [@runStorableKeyedStateVarsIO@](#v:runStorableKeyedStateVarsIO), [@runStorableKeyedStateVarsOfIO@](#v:runStorableKeyedStateVarsOfIO), [@runConstrainedKeyedStateVarsIO@](#v:runConstrainedKeyedStateVarsIO), or [@runConstrainedKeyedStateVarsOfIO@](#v:runConstrainedKeyedStateVarsOfIO).++Lawful if all references used with @getAt@ and @putAt@ are disjoint and local.+-}+runKeyedStateRefsIO ::+  forall k r.+  (Member (Embed IO) r, Reference Unconstrained k) =>+  InterpreterFor (KeyedState k) r+runKeyedStateRefsIO = runKeyedStateVarsIO id++{-|+Interpret a @KeyedState@ effect as a set of @IO@ references by mapping each key to a reference.++Lawful if all references returned by the mapping are disjoint and local.+-}+runKeyedStateVarsIO ::+  forall ref k r.+  (Member (Embed IO) r, Reference Unconstrained ref) =>+  (forall a. k a -> ref a) ->+  InterpreterFor (KeyedState k) r+runKeyedStateVarsIO h =+  runInputConst () .+  runKeyedStateVarsOfIO @() (\k _ -> h k) .+  raiseUnder++{-|+Like [@runKeyedStateVarsIO@](#v:runKeyedStateVarsIO), but for references that are accessed through some pure handle, like the [window attributes](https://hackage.haskell.org/package/sdl2/docs/SDL-Video.html#g:3) in [@sdl2@](https://hackage.haskell.org/package/sdl2) package.++Lawful if all references returned by the mapping are disjoint and local.+-}+runKeyedStateVarsOfIO ::+  forall s ref k r.+  (Members [Input s, Embed IO] r, Reference Unconstrained ref) =>+  (forall a. k a -> s -> ref a) ->+  InterpreterFor (KeyedState k) r+runKeyedStateVarsOfIO h =+  runConstrainedKeyedStateVarsOfIO @s @Unconstrained (h . getUnconstrainedKey) .+  rename UnconstrainedKey .+  raiseUnder++{-|+Interpret a @KeyedState@ effect as a set of @IO@ references by mapping each key to a reference that requires a @Storable@ constraint on values.++Lawful if all references returned by the mapping are disjoint and local.+-}+runStorableKeyedStateVarsIO ::+  forall ref k r.+  (Member (Embed IO) r, Reference Storable ref, Has Storable k) =>+  (forall a. k a -> ref a) ->+  InterpreterFor (KeyedState k) r+runStorableKeyedStateVarsIO = runConstrainedKeyedStateVarsIO @Storable++{-|+Like [@runStorableKeyedStateVarsIO@](#v:runStorableKeyedStateVarsIO), but for references that are accessed through some pure handle.++Lawful if all references returned by the mapping are disjoint and local.+-}+runStorableKeyedStateVarsOfIO ::+  forall s ref k r.+  (Members [Input s, Embed IO] r, Reference Storable ref, Has Storable k) =>+  (forall a. k a -> s -> ref a) ->+  InterpreterFor (KeyedState k) r+runStorableKeyedStateVarsOfIO = runConstrainedKeyedStateVarsOfIO @s @Storable++{-|+Interpret a @KeyedState effect as a set of @IO@ references by mapping each key to a references that requires some specified constraint on values. This will usually need the @TypeApplications@ extension to disambiguate the constraint. This can be used if you have some exotic reference type that requires a constraint other than @Storable@.++Lawful if all references returned by the mapping are disjoint and local.+-}+runConstrainedKeyedStateVarsIO ::+  forall c ref k r.+  (Member (Embed IO) r, Reference c ref, Has c k) =>+  (forall a. k a -> ref a) ->+  InterpreterFor (KeyedState k) r+runConstrainedKeyedStateVarsIO h =+  runInputConst () .+  runConstrainedKeyedStateVarsOfIO @() @c (\k _ -> h k) .+  raiseUnder++{-|+Like [@runConstrainedKeyedStateVarsIO@](#v:runConstrainedKeyedStateVarsIO), but for references that are accessed through some pure handle.++Lawful if all references returned by the mapping are disjoint and local.+-}+runConstrainedKeyedStateVarsOfIO ::+  forall s c ref k r.+  (Members [Input s, Embed IO] r, Reference c ref, Has c k) =>+  (forall a. k a -> s -> ref a) ->+  InterpreterFor (KeyedState k) r+runConstrainedKeyedStateVarsOfIO h =+  interpret $ \case+    GetAt k -> has @c k $ input >>= StateVar.get . h k+    PutAt k x -> has @c k $ input >>= \s -> h k s $= x
+ src/Polysemy/State/Keyed/Law.hs view
@@ -0,0 +1,49 @@+module Polysemy.State.Keyed.Law where++import Data.Constraint.Extras+import Data.GADT.Compare+import Data.GADT.Show+import Data.Some+import Data.Type.Equality+import Polysemy+import Polysemy.Law+import Polysemy.State.Keyed++prop_lawfulKeyedState ::+  forall k r.+  MakeLaw (KeyedState k) r =>+  (forall a. Eq a => Eq (k a), GEq k, GShow k) =>+  (Has Show k, Has Eq k, Has Arbitrary k, Arbitrary (Some k)) =>+  InterpreterFor (KeyedState k) r -> Property+prop_lawfulKeyedState f = runLaw f law_consistency++newtype KeyValuePair k a = KeyValuePair (k a, a)++instance GEq k => GEq (KeyValuePair k) where+  geq (KeyValuePair (x,_)) (KeyValuePair (y,_)) = geq x y++instance (Has Arbitrary k, Arbitrary (Some k)) => Arbitrary (Some (KeyValuePair k)) where+  arbitrary =+    withSomeM arbitrary $ \(k :: k a) ->+      has @Arbitrary k $ Some . KeyValuePair . (k,) <$> arbitrary++instance (Has Show k, GShow k) => GShow (KeyValuePair k) where+  gshowsPrec i (KeyValuePair (k, x)) s =+    has @Show k $ concat ["(", gshowsPrec i k "", ", ", showsPrec i x "", ")", s]++law_consistency ::+  forall k r.+  MakeLaw (KeyedState k) r =>+  (forall a. Eq a => Eq (k a), GEq k, GShow k) =>+  (Has Show k, Has Eq k, Has Arbitrary k, Arbitrary (Some k)) =>+  Law (KeyedState k) r+law_consistency =+  mkLaw @_ @_ @_ @(_ -> _ -> Sem _ (Some (KeyValuePair k)))+    "uncurry putAt %1 *> getAt %2"+    (\(Some (KeyValuePair (k, x))) (Some k') ->+      putAt k x *> (Some . KeyValuePair . (k',) <$> getAt k'))+    "if fst %1 == %2 then pure (snd %1) else getAt %2"+    (\(Some (KeyValuePair (k, x))) (Some k') ->+      case geq k k' of+        Just Refl | has @Eq k $ k == k' -> pure $ Some $ KeyValuePair (k, x)+        _ -> Some . KeyValuePair . (k',) <$> getAt k')
+ test/Spec.hs view
@@ -0,0 +1,89 @@+-- import Data.Constraint+import Data.Constraint.Extras+import Data.Constraint.Extras.TH+import Data.IORef+import Data.GADT.Compare+import Data.GADT.Show+import Data.Kind+import Data.Some+import Data.StateVar (($=))+import Data.Typeable+-- import Data.Type.Equality+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Polysemy+-- import Polysemy.Internal+import Polysemy.Membership+import Polysemy.State+import Polysemy.State.Keyed+import Polysemy.State.Keyed.Law+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck as QuickCheck+import Test.QuickCheck.Monadic as QuickCheck++data TestKey :: Type -> Type where+  A, B :: TestKey Int+  C :: TestKey Double+  D :: TestKey Bool++deriveArgDict ''TestKey++deriving instance Eq (TestKey a)+deriving instance Show (TestKey a)++instance GShow TestKey where+  gshowsPrec = showsPrec++instance GEq TestKey where+  geq (k :: TestKey a) (k' :: TestKey b) =+    has @Typeable k $ has @Typeable k' $ eqT @a @b++instance Arbitrary (Some TestKey) where+  arbitrary = elements [Some A, Some B, Some C, Some D]++propertyM :: Applicative m => Property -> PropertyM m ()+propertyM = MkPropertyM . const . pure . pure++spec :: Spec+spec = do+  describe "runKeyedStates" $ do+    prop "obeys the KeyedState laws" $+      \(a :: Int) (b :: Int) (c :: Double) (d :: Bool) -> do+        prop_lawfulKeyedState @_ @'[Embed IO] $+            evalState d+          . evalState c+          . evalState b+          . evalState a+          . runKeyedStates (\case A -> Here; B -> There Here; C -> There $ There Here; D -> There $ There $ There Here)+          . raiseUnder+          . raiseUnder+          . raiseUnder+          . raiseUnder++  describe "runKeyedStateStore" $ do+    prop "obeys the KeyedState laws" $+      \(a :: Int) (b :: Int) (c :: Double) (d :: Bool) -> do+        prop_lawfulKeyedState @_ @'[Embed IO] $+          evalState (KeyedStore (\case A -> a; B -> b; C -> c; D -> d)) .+          runKeyedStateStore @TestKey .+          raiseUnder++  describe "runKeyedStateVarsIO" $ do+    prop "obeys the KeyedState laws with IORef storage" $+      \(a :: Int) (b :: Int) (c :: Double) (d :: Bool) -> monadicIO $ do+        (refA,refB,refC,refD) <- QuickCheck.run $ (,,,) <$> newIORef a <*> newIORef b <*> newIORef c <*> newIORef d+        propertyM $ prop_lawfulKeyedState @_ @'[Embed IO] $+          runKeyedStateVarsIO @IORef $ \case A -> refA; B -> refB; C -> refC; D -> refD++  describe "runStorableKeyedStateVarsIO" $ do+    prop "obeys the KeyedState laws with Ptr storage" $+      \(a :: Int) (b :: Int) (c :: Double) (d :: Bool) -> monadicIO $ do+        (refA,refB,refC,refD) <- QuickCheck.run $ (,,,) <$> malloc <*> malloc <*> malloc <*> malloc+        refA $= a; refB $= b; refC $= c; refD $= d+        propertyM $ prop_lawfulKeyedState @_ @'[Embed IO] $+          runStorableKeyedStateVarsIO @Ptr $ \case A -> refA; B -> refB; C -> refC; D -> refD+        QuickCheck.run $ do free refA; free refB; free refC; free refD+        +main :: IO ()+main = hspec spec