From 5e638ebfb07fff8bfdeea0bf781b1d59a4288506 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sun, 28 Nov 2021 13:07:48 -0800 Subject: [PATCH] Remove Polysemy.Law (#437) * Remove Polysemy.Law * Beter changelog --- ChangeLog.md | 2 + package.yaml | 1 - polysemy.cabal | 12 +-- src/Polysemy/Law.hs | 197 -------------------------------------- src/Polysemy/State/Law.hs | 59 ------------ test/LawsSpec.hs | 20 ---- 6 files changed, 5 insertions(+), 286 deletions(-) delete mode 100644 src/Polysemy/Law.hs delete mode 100644 src/Polysemy/State/Law.hs delete mode 100644 test/LawsSpec.hs diff --git a/ChangeLog.md b/ChangeLog.md index c825f55..b6d9e4d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -4,6 +4,8 @@ ### Breaking Changes +- Removed `Polysemy.Law` + ### Other Changes ## 1.7.1.0 (2021-11-23) diff --git a/package.yaml b/package.yaml index 82ab712..37fc057 100644 --- a/package.yaml +++ b/package.yaml @@ -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: diff --git a/polysemy.cabal b/polysemy.cabal index c60edb0..4791c63 100644 --- a/polysemy.cabal +++ b/polysemy.cabal @@ -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 diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs deleted file mode 100644 index c4eb0af..0000000 --- a/src/Polysemy/Law.hs +++ /dev/null @@ -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 - diff --git a/src/Polysemy/State/Law.hs b/src/Polysemy/State/Law.hs deleted file mode 100644 index 8f8d90d..0000000 --- a/src/Polysemy/State/Law.hs +++ /dev/null @@ -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) - diff --git a/test/LawsSpec.hs b/test/LawsSpec.hs deleted file mode 100644 index 0777bc1..0000000 --- a/test/LawsSpec.hs +++ /dev/null @@ -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 -