github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Test the associativity of the semigroup instances.

Browse Source
This commit is contained in:
Rob Rix 2018-03-21 17:16:09 -04:00
parent 69a4e4cc2e
commit c6148c6cad
1 changed files with 9 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Data/Semigroup/App.hs
View File

@ -7,10 +7,17 @@ module Data.Semigroup.App
import Control.Applicative
import Data.Semigroup
-- $setup
-- >>> import Test.QuickCheck
-- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary
-- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary
-- | 'Semigroup' under '<*>' and '<>'.
newtype AppMerge f a = AppMerge { runAppMerge :: f a }
deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
-- $ Associativity:
-- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String)
instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where
AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b)
@ -23,6 +30,8 @@ instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where
newtype App f a = App { runApp :: f a }
deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
-- $ Associativity:
-- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer)
instance Applicative f => Semigroup (App f a) where
App a <> App b = App (a *> b)