polysemy-research/polysemy
1
1
Fork 0
mirror of https://github.com/polysemy-research/polysemy.git synced 2024-09-11 02:25:43 +03:00
Code Issues Projects Releases Wiki Activity

Remove Polysemy.Law (#437)

Browse Source 
* Remove Polysemy.Law

* Beter changelog
This commit is contained in:
Sandy Maguire 2021-11-28 13:07:48 -08:00 committed by GitHub
parent cc27631bd8
commit 5e638ebfb0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 5 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ChangeLog.md
View File

@ -4,6 +4,8 @@
### Breaking Changes
- Removed `Polysemy.Law`
### Other Changes
## 1.7.1.0 (2021-11-23)

1
package.yaml
View File

@ -29,7 +29,6 @@ dependencies:
- unagi-chan >= 0.4.0.0 && < 0.5
- async >= 2.2 && < 3
- type-errors >= 0.2.0.0
- QuickCheck >= 2.11.3 && < 3
custom-setup:
dependencies:

12
polysemy.cabal
View File

@ -68,14 +68,12 @@ library
Polysemy.Internal.Union
Polysemy.Internal.Writer
Polysemy.IO
Polysemy.Law
Polysemy.Membership
Polysemy.NonDet
Polysemy.Output
Polysemy.Reader
Polysemy.Resource
Polysemy.State
Polysemy.State.Law
Polysemy.Tagged
Polysemy.Trace
Polysemy.View
@ -103,8 +101,7 @@ library
UnicodeSyntax
ghc-options: -Wall
build-depends:
QuickCheck >=2.11.3 && <3
, async >=2.2 && <3
async >=2.2 && <3
, base >=4.9 && <5
, containers >=0.5 && <0.7
, first-class-families >=0.5.0.0 && <0.9
@ -146,7 +143,6 @@ test-suite polysemy-test
InspectorSpec
InterceptSpec
KnownRowSpec
LawsSpec
OutputSpec
TacticsSpec
ThEffectSpec
@ -177,8 +173,7 @@ test-suite polysemy-test
build-tool-depends:
hspec-discover:hspec-discover >=2.0
build-depends:
QuickCheck >=2.11.3 && <3
, async >=2.2 && <3
async >=2.2 && <3
, base >=4.9 && <5
, containers >=0.5 && <0.7
, doctest >=0.16.0.1 && <0.19
@ -223,8 +218,7 @@ benchmark polysemy-bench
TypeFamilies
UnicodeSyntax
build-depends:
QuickCheck >=2.11.3 && <3
, async >=2.2 && <3
async >=2.2 && <3
, base >=4.9 && <5
, containers >=0.5 && <0.7
, criterion

197
src/Polysemy/Law.hs
View File

@ -1,197 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 806
-- There is a bug in older versions of Haddock that don't allow documentation
-- on GADT arguments.
#define HADDOCK --
#else
#define HADDOCK -- ^
#endif
module Polysemy.Law
( Law (..)
, runLaw
, MakeLaw (..)
, Citizen (..)
, printf
, module Test.QuickCheck
) where
import Control.Arrow (first)
import Data.Char
import Polysemy
import Test.QuickCheck
------------------------------------------------------------------------------
-- | Associates the name @r@ with the eventual type @a@. For example,
-- @'Citizen' (String -> Bool) Bool@ can produce arbitrary @Bool@s by calling
-- the given function with arbitrary @String@s.
class Citizen r a | r -> a where
-- | Generate two @a@s via two @r@s. Additionally, produce a list of strings
-- corresponding to any arbitrary arguments we needed to build.
getCitizen :: r -> r -> Gen ([String], (a, a))
instance {-# OVERLAPPING #-} Citizen (Sem r a -> b) (Sem r a -> b) where
getCitizen r1 r2 = pure ([], (r1, r2))
instance Citizen (Sem r a) (Sem r a) where
getCitizen r1 r2 = pure ([], (r1, r2))
instance (Arbitrary a, Show a, Citizen b r) => Citizen (a -> b) r where
getCitizen f1 f2 = do
a <- arbitrary
first (show a :) <$> getCitizen (f1 a) (f2 a)
------------------------------------------------------------------------------
-- | A law that effect @e@ must satisfy whenever it is in environment @r@. You
-- can use 'runLaw' to transform these 'Law's into QuickCheck-able 'Property's.
data Law e r where
-- | A pure 'Law', that doesn't require any access to 'IO'.
Law
:: ( Eq a
, Show a
, Citizen i12n (Sem r x -> a)
, Citizen res (Sem (e ': r) x)
)
=> i12n
HADDOCK An interpretation from @'Sem' r x@ down to a pure value. This is
-- likely 'run'.
-> String
HADDOCK A string representation of the left-hand of the rule. This is
-- a formatted string, for more details, refer to 'printf'.
-> res
HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-- is a function type, it's guaranteed to be called with the same
-- arguments that the right-handed side was called with.
-> String
HADDOCK A string representation of the right-hand of the rule. This is
-- a formatted string, for more details, refer to 'printf'.
-> res
HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-- is a function type, it's guaranteed to be called with the same
-- arguments that the left-handed side was called with.
-> Law e r
-- | Like 'Law', but for 'IO'-accessing effects.
LawIO
:: ( Eq a
, Show a
, Citizen i12n (Sem r x -> IO a)
, Citizen res (Sem (e ': r) x)
)
=> i12n
HADDOCK An interpretation from @'Sem' r x@ down to an 'IO' value. This is
-- likely 'runM'.
-> String
HADDOCK A string representation of the left-hand of the rule. This is
-- a formatted string, for more details, refer to 'printf'.
-> res
HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-- is a function type, it's guaranteed to be called with the same
-- arguments that the right-handed side was called with.
-> String
HADDOCK A string representation of the right-hand of the rule. This is
-- a formatted string, for more details, refer to 'printf'.
-> res
HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-- is a function type, it's guaranteed to be called with the same
-- arguments that the left-handed side was called with.
-> Law e r
------------------------------------------------------------------------------
-- | A typeclass that provides the smart constructor 'mkLaw'.
class MakeLaw e r where
-- | A smart constructor for building 'Law's.
mkLaw
:: (Eq a, Show a, Citizen res (Sem (e ': r) a))
=> String
-> res
-> String
-> res
-> Law e r
instance MakeLaw e '[] where
mkLaw = Law run
instance MakeLaw e '[Embed IO] where
mkLaw = LawIO runM
------------------------------------------------------------------------------
-- | Produces a QuickCheck-able 'Property' corresponding to whether the given
-- interpreter satisfies the 'Law'.
runLaw :: InterpreterFor e r -> Law e r -> Property
runLaw i12n (Law finish str1 a str2 b) = property $ do
(_, (lower, _)) <- getCitizen finish finish
(args, (ma, mb)) <- getCitizen a b
let run_it = lower . i12n
a' = run_it ma
b' = run_it mb
pure $
counterexample
(mkCounterexampleString str1 a' str2 b' args)
(a' == b')
runLaw i12n (LawIO finish str1 a str2 b) = property $ do
(_, (lower, _)) <- getCitizen finish finish
(args, (ma, mb)) <- getCitizen a b
let run_it = lower . i12n
pure $ ioProperty $ do
a' <- run_it ma
b' <- run_it mb
pure $
counterexample
(mkCounterexampleString str1 a' str2 b' args)
(a' == b')
------------------------------------------------------------------------------
-- | Make a string representation for a failing 'runLaw' property.
mkCounterexampleString
:: Show a
=> String
-> a
-> String
-> a
-> [String]
-> String
mkCounterexampleString str1 a str2 b args =
mconcat
[ printf str1 args , " (result: " , show a , ")\n /= \n"
, printf str2 args , " (result: " , show b , ")"
]
------------------------------------------------------------------------------
-- | A bare-boned implementation of printf. This function will replace tokens
-- of the form @"%n"@ in the first string with @args !! n@.
--
-- This will only work for indexes up to 9.
--
-- For example:
--
-- >>> printf "hello %1 %2% %3 %1" ["world", "50"]
-- "hello world 50% %3 world"
printf :: String -> [String] -> String
printf str args = splitArgs str
where
splitArgs :: String -> String
splitArgs s =
case break (== '%') s of
(as, "") -> as
(as, _ : b : bs)
| isDigit b
, let d = read [b] - 1
, d < length args
-> as ++ (args !! d) ++ splitArgs bs
(as, _ : bs) -> as ++ "%" ++ splitArgs bs

59
src/Polysemy/State/Law.hs
View File

@ -1,59 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Polysemy.State.Law where
import Polysemy
import Polysemy.Law
import Polysemy.State
import Control.Applicative
import Control.Arrow
------------------------------------------------------------------------------
-- | A collection of laws that show a `State` interpreter is correct.
prop_lawfulState
:: forall r s
. (Eq s, Show s, Arbitrary s, MakeLaw (State s) r)
=> InterpreterFor (State s) r
-> Property
prop_lawfulState i12n = conjoin
[ runLaw i12n law_putTwice
, runLaw i12n law_getTwice
, runLaw i12n law_getPutGet
]
law_putTwice
:: forall s r
. (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)
=> Law (State s) r
law_putTwice =
mkLaw
"put %1 >> put %2 >> get"
(\s s' -> put @s s >> put @s s' >> get @s)
"put %2 >> get"
(\_ s' -> put @s s' >> get @s)
law_getTwice
:: forall s r
. (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)
=> Law (State s) r
law_getTwice =
mkLaw
"liftA2 (,) get get"
(liftA2 (,) (get @s) (get @s))
"(id &&& id) <$> get"
((id &&& id) <$> get @s)
law_getPutGet
:: forall s r
. (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)
=> Law (State s) r
law_getPutGet =
mkLaw
"get >>= put >> get"
(get @s >>= put @s >> get @s)
"get"
(get @s)

20
test/LawsSpec.hs
View File

@ -1,20 +0,0 @@
module LawsSpec where
import Polysemy
import Polysemy.Law
import Polysemy.State
import Polysemy.State.Law
import Test.Hspec
spec :: Spec
spec = parallel $ do
describe "State effects" $ do
it "runState should pass the laws" $
property $ prop_lawfulState @'[] $ fmap snd . runState @Int 0
it "runLazyState should pass the laws" $
property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0
it "stateToIO should pass the laws" $
property $ prop_lawfulState @'[Embed IO] $ fmap snd . stateToIO @Int 0