diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for polysemy-RandomFu +## 0.2.0.0 +- Changes to keep up with ConstraintAbsorber changes in polysemy-zoo + + ## 0.1.0.0 (2019-06-14) - Initial Release with RandomFu effect/intepreters diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -1,9 +1,13 @@ -# polysemy-RandomFu +# polysemy-RandomFu v0.2.0.0 +[![Build Status][travis-badge]][travis] +[![Hackage][hackage-badge]][hackage] +[![Hackage Dependencies][hackage-deps-badge]][hackage-deps] + ## Summary - Polysemy effect and intepreters to use the random-fu library in a polysemy effect union (like an mtl stack). -- Includes an MTL "absorber" (see https://github.com/isovector/polysemy-zoo/blob/master/src/Polysemy/MTL.hs) for -to random-fu ```MonadRandom``` typeclass. +- Includes a constraint "absorber" (see https://github.com/isovector/polysemy-zoo/blob/master/src/Polysemy/ConstraintAbsorber.hs) for +the random-fu ```MonadRandom``` typeclass. ## Example (from the tests) ```haskell @@ -32,3 +36,10 @@ ## Notes - See the tests (in https://github.com/adamConnerSax/Polysemy-Extra/blob/master/polysemy-RandomFu/test/RandomFuSpec.hs) for more details about how to use this effect + +[travis]: +[travis-badge]: +[hackage]: +[hackage-badge]: +[hackage-deps-badge]: +[hackage-deps]: diff --git a/polysemy-RandomFu.cabal b/polysemy-RandomFu.cabal --- a/polysemy-RandomFu.cabal +++ b/polysemy-RandomFu.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8b08324c19e2b90da9f91c6c9e4b0ec7b189d02891867db140555b58e4c9e461 +-- hash: eae1a0503816a03e0d5218be187818539f2cba48460bc5b150f75b11a2ea2dfb name: polysemy-RandomFu -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Experimental, RandomFu effect and interpreters for polysemy description: Please see the README on GitHub at category: Polysemy @@ -18,6 +18,7 @@ copyright: 2019 Adam Conner-Sax license: BSD3 license-file: LICENSE +tested-with: GHC ==8.6.4 build-type: Simple extra-source-files: Readme.md @@ -30,6 +31,7 @@ library exposed-modules: + Polysemy.ConstraintAbsorber.MonadRandom Polysemy.RandomFu other-modules: Paths_polysemy_RandomFu @@ -40,10 +42,10 @@ build-depends: base >=4.7 && <5 , polysemy >=0.3 - , polysemy-plugin - , polysemy-zoo >=0.2 - , random-fu - , random-source + , polysemy-plugin >0.2.0.0 && <0.4.0.0 + , polysemy-zoo >=0.3 + , random-fu >=0.2.5.0 && <0.3.0.0 + , random-source >=0.3 && <0.4.0.0 default-language: Haskell2010 test-suite polysemy-RandomFu-test @@ -56,14 +58,16 @@ 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-tool-depends: + hspec-discover:hspec-discover >=2.0 build-depends: base >=4.7 && <5 - , hspec + , hspec >=2.0 , polysemy >=0.3 , polysemy-RandomFu - , polysemy-plugin + , polysemy-plugin >0.2.0.0 && <0.4.0.0 , polysemy-zoo - , random-fu - , random-source - , text + , random-fu >=0.2.5.0 && <0.3.0.0 + , random-source >=0.3 && <0.4.0.0 + , text >=1.1.0.0 && <1.3.0.0 default-language: Haskell2010 diff --git a/src/Polysemy/ConstraintAbsorber/MonadRandom.hs b/src/Polysemy/ConstraintAbsorber/MonadRandom.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/ConstraintAbsorber/MonadRandom.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.ConstraintAbsorber.MonadRandom + ( + absorbMonadRandom + ) +where + +import Polysemy +import Polysemy.ConstraintAbsorber +import Polysemy.RandomFu + +import qualified Data.Random.Source as R +import qualified Data.Random.Internal.Source as R + +------------------------------------------------------------------------------ +-- | absorb a @MonadError e@ constraint into @Member (Error e) r => Sem r@ +absorbMonadRandom :: Member RandomFu r + => (R.MonadRandom (Sem r) => Sem r a) -> Sem r a +absorbMonadRandom = absorbWithSem @R.MonadRandom @Action + (RandomDict getRandomPrim) + (Sub Dict) +{-# INLINEABLE absorbMonadRandom #-} + +-- | A dictionary of the functions we need to supply +-- to make an instance of MonadRandom +data RandomDict m = RandomDict { getRandomPrim_ :: forall t. R.Prim t -> m t } + +-- | Wrapper for a monadic action with phantom +-- type parameter for reflection. +-- Locally defined so that the instance we are going +-- to build with reflection must be coherent, that is +-- there cannot be orphans. +newtype Action m s' a = Action { action :: m a } + deriving (Functor, Applicative, Monad) + +-- | Given a reifiable mtl Error dictionary, +-- we can make an instance of @MonadError@ for the action +-- wrapped in @Action@. +$(R.monadRandom [d| + instance ( Monad m + , Reifies s' (RandomDict m) + ) => R.MonadRandom (Action m s') where + getRandomPrim t = Action + $ getRandomPrim_ (reflect $ Proxy @s') t + {-# INLINEABLE getRandomPrim #-} + |]) diff --git a/src/Polysemy/RandomFu.hs b/src/Polysemy/RandomFu.hs --- a/src/Polysemy/RandomFu.hs +++ b/src/Polysemy/RandomFu.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} {-| Module : Polysemy.RandomFu Description : Polysemy random-fu effect @@ -33,18 +29,14 @@ , runRandomSource , runRandomIO , runRandomIOPureMT - - -- * Constraint absorber - , absorbMonadRandom ) where import Polysemy -import Polysemy.MTL +--import Polysemy.MTL import Data.IORef ( newIORef ) import qualified Data.Random as R -import qualified Data.Random.Source as R import qualified Data.Random.Internal.Source as R import qualified Data.Random.Source.PureMT as R import Control.Monad.IO.Class ( MonadIO(..) ) @@ -105,35 +97,3 @@ liftIO (newIORef source) >>= flip runRandomSource re {-# INLINEABLE runRandomIOPureMT #-} ------------------------------------------------------------------------------- --- | "Absorb" an 'R.MonadRandom' constraint. --- That is, use a @Member RandomFu r@ constraint to satisfy the @MonadRandom@ --- constraint in a @(forall m. MonadRandom m => m a), returning a @Sem r a@. --- See 'Polysemy.MTL' for details. -absorbMonadRandom - :: Member RandomFu r => (R.MonadRandom (Sem r) => Sem r a) -> Sem r a -absorbMonadRandom = absorb @R.MonadRandom -{-# INLINEABLE absorbMonadRandom #-} - -type instance CanonicalEffect R.MonadRandom = RandomFu - -instance ReifiableConstraint1 (R.MonadRandom) where - data Dict1 R.MonadRandom m = MonadRandom - { - getRandomPrim_ :: forall t. R.Prim t -> m t - } - reifiedInstance = Sub Dict - - -$(R.monadRandom [d| - instance ( Monad m - , Reifies s' (Dict1 R.MonadRandom m) - ) => R.MonadRandom (ConstrainedAction R.MonadRandom m s') where - getRandomPrim t = ConstrainedAction - $ getRandomPrim_ (reflect $ Proxy @s') t - {-# INLINEABLE getRandomPrim #-} - |]) - -instance Member RandomFu r => IsCanonicalEffect R.MonadRandom r where - canonicalDictionary = MonadRandom getRandomPrim - {-# INLINEABLE canonicalDictionary #-} diff --git a/test/RandomFuSpec.hs b/test/RandomFuSpec.hs --- a/test/RandomFuSpec.hs +++ b/test/RandomFuSpec.hs @@ -5,6 +5,7 @@ import Polysemy import Polysemy.RandomFu +import Polysemy.ConstraintAbsorber.MonadRandom import Test.Hspec import Control.Monad as M