diff --git a/.travis.yml b/.travis.yml index f62a89d..a4157a3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,32 +1,120 @@ -sudo: false - -cache: - directories: - - $HOME/.ghc - - $HOME/.cabal - - $HOME/.stack - -matrix: - include: - - os: osx - before_install: - - brew update - - brew install haskell-stack - - - os: linux - addons: - apt: - packages: - - libgmp-dev - before_install: - - mkdir -p ~/.local/bin - - export PATH=$HOME/.local/bin:$PATH - - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - -before_script: - - stack setup - - stack exec -- ghc --version - - stack build - -script: - - stack test +# This Travis job script has been generated by a script via +# +# haskell-ci 'selective.cabal' '--osx=8.6.4' '-o' '.travis.yml' +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.2.1 +# +language: c +dist: xenial + +git: + submodules: false # whether to recursively clone submodules + +cache: + directories: + - $HOME/.cabal/packages + - $HOME/.cabal/store + - $HOME/.ghc-install + +before_cache: + - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* + - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx + + - rm -rfv $CABALHOME/packages/head.hackage + +matrix: + include: + - compiler: "ghc-8.6.4" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4], sources: [hvr-ghc]}} + - compiler: "ghc-8.4.3" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.3], sources: [hvr-ghc]}} + - compiler: "ghc-8.2.2" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.0.2" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.6.4" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4], sources: [hvr-ghc]}} + os: osx + +before_install: + - HC=/opt/ghc/bin/${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - CABAL=/opt/ghc/bin/cabal + - CABALHOME=$HOME/.cabal + - export PATH="$CABALHOME/bin:$PATH" + - ROOTDIR=$(pwd) + - if [ "$TRAVIS_OS_NAME" = "osx" ]; then brew update; brew upgrade python@3; curl https://haskell.futurice.com/haskell-on-macos.py | python3 - --make-dirs --install-dir=$HOME/.ghc-install --cabal-alias=head install cabal-install-head ${TRAVIS_COMPILER}; fi + - if [ "$TRAVIS_OS_NAME" = "osx" ]; then HC=$HOME/.ghc-install/ghc/bin/$TRAVIS_COMPILER; HCPKG=${HC/ghc/ghc-pkg}; CABAL=$HOME/.ghc-install/ghc/bin/cabal; fi + - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - echo $HCNUMVER + +install: + - ${CABAL} --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - TEST=--enable-tests + - BENCH=--enable-benchmarks + - GHCHEAD=${GHCHEAD-false} + - travis_retry ${CABAL} update -v + - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config + - rm -fv cabal.project cabal.project.local + - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' + - rm -f cabal.project + - touch cabal.project + - "printf 'packages: \".\"\\n' >> cabal.project" + - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" + - touch cabal.project.local + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(selective)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi + - rm -f cabal.project.freeze + - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry + - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm "cabal.project.freeze" + - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all + - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all + - rm -rf .ghc.environment.* "."/dist + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. +script: + # test that source-distributions can be generated + - ${CABAL} new-sdist all + - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; + - rm -f cabal.project + - touch cabal.project + - "printf 'packages: \"selective-*/*.cabal\"\\n' >> cabal.project" + - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" + - touch cabal.project.local + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(selective)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + # this builds all libraries and executables (without tests/benchmarks) + - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all + + # build & run tests, build benchmarks + - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all + - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all; fi + + # cabal check + - (cd selective-* && ${CABAL} check) + + # haddock + - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all + + # Build without installed constraints for packages in global-db + - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all; + +# REGENDATA ["selective.cabal","--osx=8.6.4","-o",".travis.yml"] +# EOF diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..2d8eca7 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,7 @@ +# Change log + +## 0.2 + +* Make compatible with GHC >= 8.0.2. +* Add another free construction `Control.Selective.Free`. +* Add several new `Selective` instances. diff --git a/examples/Processor.hs b/examples/Processor.hs index e359962..42e7856 100644 --- a/examples/Processor.hs +++ b/examples/Processor.hs @@ -271,9 +271,9 @@ willOverflow arg1 arg2 = renderState :: State -> String renderState state = - "Registers: " <> show (registers state) <> "\n" <> - "Flags: " <> show (Map.toList $ flags state) <> "\n" <> - "Log: " <> show (log state) + "Registers: " ++ show (registers state) ++ "\n" ++ + "Flags: " ++ show (Map.toList $ flags state) ++ "\n" ++ + "Log: " ++ show (log state) instance Show State where show = renderState diff --git a/selective.cabal b/selective.cabal index 40c93c4..6e708c2 100644 --- a/selective.cabal +++ b/selective.cabal @@ -1,5 +1,5 @@ name: selective -version: 0.1.0 +version: 0.2 synopsis: Selective applicative functors license: MIT license-file: LICENSE @@ -10,7 +10,10 @@ homepage: https://github.com/snowleopard/selective category: Control build-type: Simple cabal-version: 1.18 -tested-with: GHC==8.6.4 +tested-with: GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.3, + GHC==8.6.4 stability: experimental description: Selective applicative functors: declare your effects statically, select which to execute dynamically. @@ -33,17 +36,17 @@ library Control.Selective.Free, Control.Selective.Free.Rigid build-depends: base >= 4.7 && < 5, - containers >= 0.5.7.1 && < 7, - transformers >= 0.5.2.0 && < 0.6 + containers >= 0.5.5.1 && < 0.7, + transformers >= 0.4.2.0 && < 0.6 default-language: Haskell2010 other-extensions: DeriveFunctor, - DerivingVia, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, - TupleSections + TupleSections, + TypeApplications GHC-options: -Wall -fno-warn-name-shadowing -Wcompat @@ -63,13 +66,13 @@ test-suite test type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >= 4.7 && < 5, - containers >= 0.5.7.1 && < 7, + containers >= 0.5.5.1 && < 0.7, mtl >= 2.2.1 && < 2.3, - QuickCheck >= 2.9 && < 2.13, + QuickCheck >= 2.8 && < 2.14, selective, - tasty >= 1.2, - tasty-expected-failure >= 0.11.1.1, - tasty-quickcheck >= 0.10 + tasty >= 0.11, + tasty-expected-failure >= 0.11, + tasty-quickcheck >= 0.8.4 default-language: Haskell2010 GHC-options: -Wall -fno-warn-name-shadowing @@ -77,5 +80,3 @@ test-suite test -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - -fno-warn-orphans - -fno-warn-missing-signatures diff --git a/src/Control/Selective.hs b/src/Control/Selective.hs index 2425a22..3cd1254 100644 --- a/src/Control/Selective.hs +++ b/src/Control/Selective.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TupleSections, DeriveFunctor #-} -{-# LANGUAGE DerivingVia, StandaloneDeriving, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, TupleSections, DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective @@ -23,8 +23,7 @@ module Control.Selective ( foldS, anyS, allS, bindS, Cases, casesEnum, cases, matchS, matchM, -- * Selective functors - SelectA (..), SelectM (..), Over (..), getOver, Under (..), getUnder, - Validation (..) + SelectA (..), SelectM (..), Over (..), Under (..), Validation (..) ) where import Control.Applicative @@ -45,6 +44,7 @@ import Data.Functor.Identity import Data.Functor.Product import Data.List.NonEmpty import Data.Proxy +import Data.Semigroup (Semigroup (..)) import GHC.Conc (STM) import qualified Control.Monad.Trans.RWS.Strict as S @@ -306,7 +306,11 @@ allS :: Selective f => (a -> f Bool) -> [a] -> f Bool allS p = foldr ((<&&>) . p) (pure True) -- | Generalised folding with the short-circuiting behaviour. -foldS :: (Selective f, Foldable t, Monoid a) => t (f (Either e a)) -> f (Either e a) +foldS :: (Selective f, Foldable t, Monoid a +#if !MIN_VERSION_base(4,11,0) + , Semigroup a +#endif + ) => t (f (Either e a)) -> f (Either e a) foldS = foldr andAlso (pure (Right mempty)) -- Instances @@ -335,26 +339,27 @@ instance Monad f => Selective (SelectM f) where select = selectM -- | Static analysis of selective functors with over-approximation. -newtype Over m a = Over m - deriving (Functor, Applicative, Selective) via SelectA (Const m) - deriving Show +newtype Over m a = Over { getOver :: m } + deriving (Eq, Functor, Ord, Show) --- | Extract the contents of 'Over'. -getOver :: Over m a -> m -getOver (Over x) = x +instance Monoid m => Applicative (Over m) where + pure _ = Over mempty + Over x <*> Over y = Over (mappend x y) + +instance Monoid m => Selective (Over m) where + select (Over x) (Over y) = Over (mappend x y) -- | Static analysis of selective functors with under-approximation. -newtype Under m a = Under m - deriving (Functor, Applicative) via Const m - deriving Show +newtype Under m a = Under { getUnder :: m } + deriving (Eq, Functor, Ord, Show) + +instance Monoid m => Applicative (Under m) where + pure _ = Under mempty + Under x <*> Under y = Under (mappend x y) instance Monoid m => Selective (Under m) where select (Under m) _ = Under m --- | Extract the contents of 'Under'. -getUnder :: Under m a -> m -getUnder (Under x) = x - -- The 'Selective' 'ZipList' instance corresponds to the SIMT execution model. -- Quoting https://en.wikipedia.org/wiki/Single_instruction,_multiple_threads: -- @@ -362,7 +367,7 @@ getUnder (Under x) = x -- different paths, all threads must actually process both paths (as all threads -- of a processor always execute in lock-step), but masking is used to disable -- and enable the various threads as appropriate..." -deriving via SelectA ZipList instance Selective ZipList +instance Selective ZipList where select = selectA -- | Selective instance for the standard applicative functor Validation. -- This is a good example of a selective functor which is not a monad. @@ -390,36 +395,36 @@ instance (Selective f, Selective g) => Selective (Product f g) where -- instance (Alternative f, Applicative g) => Alternative (Compose f g) ... -- instance (Applicative f, Selective g) => Selective (Compose f g) where - select (Compose x) (Compose y) = Compose $ select <$> x <*> y + select (Compose x) (Compose y) = Compose (select <$> x <*> y) -- Monad instances -- As a quick experiment, try: ifS (pure True) (print 1) (print 2) -deriving via SelectM IO instance Selective IO +instance Selective IO where select = selectM -- And... we need to write a lot more instances -deriving via SelectM [] instance Selective [] -deriving via SelectM ((,) a) instance Monoid a => Selective ((,) a) -deriving via SelectM ((->) a) instance Selective ((->) a) -deriving via SelectM (Either e) instance Selective (Either e) -deriving via SelectM Identity instance Selective Identity -deriving via SelectM Maybe instance Selective Maybe -deriving via SelectM NonEmpty instance Selective NonEmpty -deriving via SelectM Proxy instance Selective Proxy -deriving via SelectM (ST s) instance Selective (ST s) -deriving via SelectM STM instance Selective STM - -deriving via SelectM (ContT r m) instance Selective (ContT r m) -deriving via SelectM (ExceptT e m) instance Monad m => Selective (ExceptT e m) -deriving via SelectM (IdentityT m) instance Monad m => Selective (IdentityT m) -deriving via SelectM (MaybeT m) instance Monad m => Selective (MaybeT m) -deriving via SelectM (ReaderT r m) instance Monad m => Selective (ReaderT r m) -deriving via SelectM (RWST r w s m) instance (Monoid w, Monad m) => Selective (RWST r w s m) -deriving via SelectM (S.RWST r w s m) instance (Monoid w, Monad m) => Selective (S.RWST r w s m) -deriving via SelectM (StateT s m) instance Monad m => Selective (StateT s m) -deriving via SelectM (S.StateT s m) instance Monad m => Selective (S.StateT s m) -deriving via SelectM (WriterT w m) instance (Monoid w, Monad m) => Selective (WriterT w m) -deriving via SelectM (S.WriterT w m) instance (Monoid w, Monad m) => Selective (S.WriterT w m) +instance Selective [] where select = selectM +instance Monoid a => Selective ((,) a) where select = selectM +instance Selective ((->) a) where select = selectM +instance Selective (Either e) where select = selectM +instance Selective Identity where select = selectM +instance Selective Maybe where select = selectM +instance Selective NonEmpty where select = selectM +instance Selective Proxy where select = selectM +instance Selective (ST s) where select = selectM +instance Selective STM where select = selectM + +instance Selective (ContT r m) where select = selectM +instance Monad m => Selective (ExceptT e m) where select = selectM +instance Monad m => Selective (IdentityT m) where select = selectM +instance Monad m => Selective (MaybeT m) where select = selectM +instance Monad m => Selective (ReaderT r m) where select = selectM +instance (Monoid w, Monad m) => Selective (RWST r w s m) where select = selectM +instance (Monoid w, Monad m) => Selective (S.RWST r w s m) where select = selectM +instance Monad m => Selective (StateT s m) where select = selectM +instance Monad m => Selective (S.StateT s m) where select = selectM +instance (Monoid w, Monad m) => Selective (WriterT w m) where select = selectM +instance (Monoid w, Monad m) => Selective (S.WriterT w m) where select = selectM ------------------------------------ Arrows ------------------------------------ -- See the following standard definitions in "Control.Arrow". @@ -436,10 +441,17 @@ toArrow (ArrowMonad f) = arr (\x -> ((), x)) >>> first f >>> arr (uncurry ($)) ---------------------------------- Alternative --------------------------------- newtype ComposeEither f e a = ComposeEither (f (Either e a)) deriving Functor - deriving Applicative via Compose f (Either e) -instance (Selective f, Monoid e) => Alternative (ComposeEither f e) where - empty = ComposeEither $ pure $ Left mempty +instance Applicative f => Applicative (ComposeEither f e) where + pure a = ComposeEither (pure $ Right a) + ComposeEither x <*> ComposeEither y = ComposeEither ((<*>) <$> x <*> y) + +instance (Selective f, Monoid e +#if !MIN_VERSION_base(4,11,0) + , Semigroup e +#endif + ) => Alternative (ComposeEither f e) where + empty = ComposeEither (pure $ Left mempty) ComposeEither x <|> ComposeEither y = ComposeEither (x `orElse` y) {- One could also try implementing 'select' via 'Alternative' as follows: diff --git a/test/Laws.hs b/test/Laws.hs index 5ad26d9..b15a738 100644 --- a/test/Laws.hs +++ b/test/Laws.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE StandaloneDeriving, DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, TupleSections, TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Laws where import Test.QuickCheck hiding (Failure, Success) import Data.Bifunctor (bimap, first, second) import Control.Arrow hiding (first, second) -import Data.Functor.Const import Control.Selective import Data.Functor.Identity import Control.Monad.State @@ -99,8 +99,9 @@ propertyPureLeft x y = (pure (Left x) <*? y) == (($x) <$> y) -------------------------------------------------------------------------------- ------------------------ Over -------------------------------------------------- -------------------------------------------------------------------------------- -deriving instance Eq m => Eq (Over m a) -deriving via (Const m a) instance Arbitrary m => Arbitrary (Over m a) +instance Arbitrary a => Arbitrary (Over a b) where + arbitrary = Over <$> arbitrary + shrink = map Over . shrink . getOver propertyPureRightOver :: IO () propertyPureRightOver = quickCheck (propertyPureRight @(Over String) @Int) @@ -108,8 +109,9 @@ propertyPureRightOver = quickCheck (propertyPureRight @(Over String) @Int) -------------------------------------------------------------------------------- ------------------------ Under ------------------------------------------------- -------------------------------------------------------------------------------- -deriving instance Eq m => Eq (Under m a) -deriving via (Const m a) instance Arbitrary m => Arbitrary (Under m a) +instance Arbitrary a => Arbitrary (Under a b) where + arbitrary = Under <$> arbitrary + shrink = map Under . shrink . getUnder propertyPureRightUnder :: IO () propertyPureRightUnder = quickCheck (propertyPureRight @(Under String) @Int) @@ -119,18 +121,10 @@ propertyPureRightUnder = quickCheck (propertyPureRight @(Under String) @Int) -------------------------------------------------------------------------------- deriving instance (Eq e, Eq a) => Eq (Validation e a) --- | This is a copy-paste of the 'Arbitrary2' instance for 'Either' defined in --- the 'Test.QuickCheck.Arbitrary' module. 'Left' is renamed to 'Failure' and --- 'Right' to 'Success'. -instance Arbitrary2 Validation where - liftArbitrary2 arbA arbB = oneof [liftM Failure arbA, liftM Success arbB] - - liftShrink2 shrA _ (Failure x) = [ Failure x' | x' <- shrA x ] - liftShrink2 _ shrB (Success y) = [ Success y' | y' <- shrB y ] - instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where - arbitrary = arbitrary2 - shrink = shrink2 + arbitrary = oneof [liftM Failure arbitrary, liftM Success arbitrary] + shrink (Failure x) = [ Failure x' | x' <- shrink x ] + shrink (Success y) = [ Success y' | y' <- shrink y ] -------------------------------------------------------------------------------- ------------------------ ArrowMonad -------------------------------------------- diff --git a/test/Main.hs b/test/Main.hs index a5bbe11..d7f5eb8 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -75,6 +75,7 @@ overLaws = testGroup "Laws" \x -> lawAssociativity @(Over String) @Int @Int x ] +overTheorems :: TestTree overTheorems = testGroup "Theorems" [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Over String) @Int @Int x @@ -90,6 +91,7 @@ overTheorems = testGroup "Theorems" \x -> theorem6 @(Over String) @Int @Int x ] +overProperties :: TestTree overProperties = testGroup "Properties" [ expectFail $ testProperty "pure-right: pure (Right x) <*? y = pure x" $ @@ -124,8 +126,8 @@ underTheorems = testGroup "Theorems" \x -> theorem3 @(Under String) @Int @Int @Int x , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Under String) @Int @Int x - , expectFailBecause "'Under' is a non-rigid selective functor" $ - testProperty "(f <*> g) == (f `apS` g)" $ + -- 'Under' is a non-rigid selective functor + , expectFail $ testProperty "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Under String) @Int @Int x , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Under String) @Int @Int x @@ -167,11 +169,11 @@ validationTheorems = testGroup "Theorems" \x -> theorem3 @(Validation String) @Int @Int @Int x , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Validation String) @Int @Int x - , expectFailBecause "'Validation' is a non-rigid selective functor" $ - testProperty "(f <*> g) == (f `apS` g)" $ + -- 'Validation' is a non-rigid selective functor + , expectFail $ testProperty "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Validation String) @Int @Int x - , expectFailBecause "'Validation' is a non-rigid selective functor" $ - testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + -- 'Validation' is a non-rigid selective functor + , expectFail $ testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Validation String) @Int @Int @Int x ] @@ -207,6 +209,7 @@ arrowMonad :: TestTree arrowMonad = testGroup "ArrowMonad (->)" [arrowMonadLaws, arrowMonadTheorems, arrowMonadProperties] +arrowMonadLaws :: TestTree arrowMonadLaws = testGroup "Laws" [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(ArrowMonad (->)) @Int x @@ -220,6 +223,7 @@ arrowMonadLaws = testGroup "Laws" \x -> selectALaw @(ArrowMonad (->)) @Int @Int x ] +arrowMonadTheorems :: TestTree arrowMonadTheorems = testGroup "Theorems" [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(ArrowMonad (->)) @Int @Int @Int x @@ -235,6 +239,7 @@ arrowMonadTheorems = testGroup "Theorems" \x -> theorem6 @(ArrowMonad (->)) @Int @Int @Int x ] +arrowMonadProperties :: TestTree arrowMonadProperties = testGroup "Properties" [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(ArrowMonad (->)) @Int @Int x @@ -247,6 +252,7 @@ arrowMonadProperties = testGroup "Properties" maybe :: TestTree maybe = testGroup "Maybe" [maybeLaws, maybeTheorems, maybeProperties] +maybeLaws :: TestTree maybeLaws = testGroup "Laws" [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @Maybe @Int x @@ -258,6 +264,7 @@ maybeLaws = testGroup "Laws" \x -> lawMonad @Maybe @Int @Int x ] +maybeTheorems :: TestTree maybeTheorems = testGroup "Theorems" [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @Maybe @Int @Int @Int x @@ -273,6 +280,7 @@ maybeTheorems = testGroup "Theorems" \x -> theorem6 @Maybe @Int @Int @Int x ] +maybeProperties :: TestTree maybeProperties = testGroup "Properties" [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @Maybe @Int @Int x @@ -286,6 +294,7 @@ identity :: TestTree identity = testGroup "Identity" [identityLaws, identityTheorems, identityProperties] +identityLaws :: TestTree identityLaws = testGroup "Laws" [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @Identity @Int x @@ -297,6 +306,7 @@ identityLaws = testGroup "Laws" \x -> lawMonad @Identity @Int @Int x ] +identityTheorems :: TestTree identityTheorems = testGroup "Theorems" [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @Identity @Int @Int @Int x @@ -312,6 +322,7 @@ identityTheorems = testGroup "Theorems" \x -> theorem6 @Identity @Int @Int @Int x ] +identityProperties :: TestTree identityProperties = testGroup "Properties" [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @Identity @Int @Int x diff --git a/test/Sketch.hs b/test/Sketch.hs index 7173301..52d4d56 100644 --- a/test/Sketch.hs +++ b/test/Sketch.hs @@ -464,7 +464,7 @@ newtype ConstArrow m a b = ConstArrow { getConstArrow :: m } instance Monoid m => Category (ConstArrow m) where id = ConstArrow mempty - ConstArrow x . ConstArrow y = ConstArrow (x <> y) + ConstArrow x . ConstArrow y = ConstArrow (mappend x y) instance Monoid m => Arrow (ConstArrow m) where arr _ = ConstArrow mempty