packages feed

hedgehog-classes 0.2.2 → 0.2.3

raw patch · 11 files changed

+477/−53 lines, 11 filesdep +comonadPVP ok

version bump matches the API change (PVP)

Dependencies added: comonad

API changes (from Hackage documentation)

+ Hedgehog.Classes: comonadLaws :: (Comonad f, forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) => (forall x. Gen x -> Gen (f x)) -> Laws

Files

CHANGELOG.md view
@@ -3,6 +3,12 @@ `hedgehog-classes` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +0.2.3+=====+* Semirings upper bound increased to 0.5. Lower bound not touched.+  [0.2, 0.4) -> [0.2, 0.5)+* Add `comonadLaws`.+ 0.2.2 ===== * fix problem in storable set-get that caused attempt to index into
hedgehog-classes.cabal view
@@ -2,7 +2,7 @@ name:   hedgehog-classes version:-  0.2.2+  0.2.3 synopsis:   Hedgehog will eat your typeclass bugs description:@@ -58,6 +58,14 @@ --   default: True --   manual: True +flag comonad+  description:+    You can disable the use of the `comonad` package using `-f-comonad`.+    .+    This may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True+ flag semirings   description:     You can disable the use of the `semirings` package using `-f-semirings`.@@ -92,6 +100,7 @@       Hedgehog.Classes.Common.Laws       Hedgehog.Classes.Common.Property       Hedgehog.Classes.Common.PP+    Hedgehog.Classes.Comonad     Hedgehog.Classes.Contravariant     Hedgehog.Classes.Enum     Hedgehog.Classes.Eq@@ -134,51 +143,59 @@ --    build-depends: semigroupoids >= 0.5.3.0 && < 0.6.0.0 --    cpp-options: -DHAVE_SEMIGROUPOIDS   if flag(semirings)-    build-depends: semirings >= 0.2 && < 0.4+    build-depends: semirings >= 0.2 && < 0.5     cpp-options: -DHAVE_SEMIRINGS+  if flag(comonad)+    build-depends: comonad >= 5.0 && < 5.1+    cpp-options: -DHAVE_COMONAD --  if flag(vector) --    build-depends: vector >= 0.12.0.0 && < 0.13.0.0 --    cpp-options: -DHAVE_VECTOR  test-suite spec-  type:                exitcode-stdio-1.0-  hs-source-dirs:      test-  main-is:             Spec.hs--  other-modules:       Spec.Alternative-                       Spec.Applicative-                       Spec.Arrow-                       Spec.Bifoldable-                       Spec.Bifunctor-                       Spec.Binary-                       Spec.Bitraversable-                       Spec.Bits-                       Spec.Category-                       Spec.Contravariant-                       Spec.Enum-                       Spec.Eq-                       Spec.Foldable-                       Spec.Functor-                       Spec.Generic-                       Spec.Integral---                       Spec.Ix-                       Spec.Json-                       Spec.Monad-                       Spec.Monoid-                       Spec.Ord-                       Spec.Semigroup-                       Spec.Semiring-                       Spec.Show-                       Spec.Storable-                       Spec.Traversable--  build-depends:       base-                     , aeson-                     , binary-                     , containers-                     , hedgehog-                     , hedgehog-classes--  ghc-options:         -Wall--  default-language:    Haskell2010+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    Spec.hs+  other-modules:+    Spec.Alternative+    Spec.Applicative+    Spec.Arrow+    Spec.Bifoldable+    Spec.Bifunctor+    Spec.Binary+    Spec.Bitraversable+    Spec.Bits+    Spec.Category+    Spec.Comonad+    Spec.Contravariant+    Spec.Enum+    Spec.Eq+    Spec.Foldable+    Spec.Functor+    Spec.Generic+    Spec.Integral+--    Spec.Ix+    Spec.Json+    Spec.Monad+    Spec.Monoid+    Spec.Ord+    Spec.Semigroup+    Spec.Semiring+    Spec.Show+    Spec.Storable+    Spec.Traversable+  build-depends:+    , aeson+    , base+    , binary+    , comonad+    , containers+    , hedgehog+    , hedgehog-classes+  ghc-options:+    -Wall+  default-language:+    Haskell2010
src/Hedgehog/Classes.hs view
@@ -46,6 +46,9 @@     -- ** Unary type constructors   , alternativeLaws   , applicativeLaws+#ifdef HAVE_COMONAD+  , comonadLaws+#endif   , contravariantLaws   , foldableLaws   , functorLaws@@ -89,6 +92,9 @@ import Hedgehog.Classes.Bits (bitsLaws) import Hedgehog.Classes.Category (categoryLaws, commutativeCategoryLaws) import Hedgehog.Classes.Common+#ifdef HAVE_COMONAD+import Hedgehog.Classes.Comonad (comonadLaws)+#endif import Hedgehog.Classes.Contravariant (contravariantLaws) import Hedgehog.Classes.Enum (enumLaws, boundedEnumLaws) import Hedgehog.Classes.Eq (eqLaws)
src/Hedgehog/Classes/Common/Equation.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}  module Hedgehog.Classes.Common.Equation   ( LinearEquation(..), runLinearEquation, genLinearEquation@@ -9,6 +12,9 @@   , QuadraticEquation(..), runQuadraticEquation, genQuadraticEquation   , CubicEquation(..), runCubicEquation, genCubicEquation +#ifdef HAVE_COMONAD+  , LinearEquationW(..), runLinearEquationW, genLinearEquationW+#endif   ) where  import Hedgehog@@ -19,6 +25,10 @@  import Data.Monoid (Endo(..)) +#ifdef HAVE_COMONAD+import Control.Comonad+#endif+ data QuadraticEquation = QuadraticEquation   { _quadraticEquationQuadratic :: Integer   , _quadraticEquationLinear :: Integer@@ -61,6 +71,30 @@  genLinearEquation :: Gen LinearEquation genLinearEquation = LinearEquation <$> genSmallInteger <*> genSmallInteger+#ifdef HAVE_COMONAD+data LinearEquationW w = LinearEquationW (w LinearEquation) (w LinearEquation)++deriving instance (forall x. Eq x => Eq (w x)) => Eq (LinearEquationW w)+instance (forall x. Show x => Show (w x)) => Show (LinearEquationW w) where+  show (LinearEquationW a b) = (\f -> f "")+    $ showString "\\x -> if odd x then "+    . showsPrec 0 a+    . showString " else "+    . showsPrec 0 b++runLinearEquationW :: Comonad w+  => LinearEquationW w -> w Integer -> Integer+runLinearEquationW (LinearEquationW e1 e2) (extract -> i) = if odd i+  then runLinearEquation (extract e1) i+  else runLinearEquation (extract e2) i++genLinearEquationW :: Comonad w+  => (forall x. Gen x -> Gen (w x))+  -> Gen (LinearEquationW w)+genLinearEquationW fgen = LinearEquationW+  <$> fgen genLinearEquation+  <*> fgen genLinearEquation+#endif  data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation) 
+ src/Hedgehog/Classes/Comonad.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}++#ifndef HAVE_COMONAD++module Hedgehog.Classes.Comonad () where++#else++module Hedgehog.Classes.Comonad (comonadLaws) where++import Control.Comonad++import Hedgehog+import Hedgehog.Classes.Common++comonadLaws ::+  ( Comonad f+  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)+  ) => (forall x. Gen x -> Gen (f x)) -> Laws+comonadLaws gen = Laws "Comonad"+  [ ("Extend/Extract Identity", extendExtractIdentity gen)+  , ("Extract/Extend", extractExtend gen)+  , ("Extend/Extend", extendExtend gen)+  , ("Extract Right Identity", extractRightIdentity gen)+  , ("Extract Left Identity", extractLeftIdentity gen)+  , ("Cokleisli Associativity", cokleisliAssociativity gen)+  , ("Extract/Duplicate Identity", extractDuplicateIdentity gen)+  , ("Fmap Extract/Duplicate Identity", fmapExtractDuplicateIdentity gen)+  , ("Double Duplication", doubleDup gen)+  , ("Extend/Fmap . Duplicate Identity", extendDuplicate gen)+  , ("Duplicate/Extend id Identity", duplicateExtendId gen)+  , ("Fmap/Extend Extract", fmapExtendExtract gen)+  , ("Fmap/LiftW Isomorphism", fmapLiftW gen)+  ]++type ComonadProp f =+  ( Comonad f+  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)+  ) => (forall x. Gen x -> Gen (f x)) -> Property++extendExtractIdentity :: forall f. ComonadProp f+extendExtractIdentity fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  let lhs = extend extract x+  let rhs = x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extend/Extract Identity", lawContextTcName = "Comonad"+        , lawContextLawBody = "extend extract" `congruency` "id"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "extend extract x" `congruency` "x, where"+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++extractExtend :: forall f. ComonadProp f+extractExtend fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  k <- forAll $ genLinearEquationW fgen+  let k' = runLinearEquationW k+  let lhs = extract . extend k' $ x+  let rhs = k' x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extract/Extend", lawContextTcName = "Comonad"+        , lawContextLawBody = "extract . extend f" `congruency` "f"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "extract . extend f $ x" `congruency` "f x, where"+            , "f = " ++ show k+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++extendExtend :: forall f. ComonadProp f+extendExtend fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  f' <- forAll $ genLinearEquationW fgen+  g' <- forAll $ genLinearEquationW fgen+  let f = runLinearEquationW f'+  let g = runLinearEquationW g'+  let lhs = extend f . extend g $ x+  let rhs = extend (f . extend g) x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extend/Extend", lawContextTcName = "Comonad"+        , lawContextLawBody = "extend f . extend g" `congruency` "extend (f . extend g)"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "extend f . extend g $ x" `congruency` "extend (f . extend g) $ x, where"+            , "f = " ++ show f'+            , "g = " ++ show g'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++extractRightIdentity :: forall f. ComonadProp f+extractRightIdentity fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  f' <- forAll $ genLinearEquationW fgen+  let f = runLinearEquationW f'+  let lhs = f =>= extract $ x+  let rhs = f x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extract Cokleisli Right Identity", lawContextTcName = "Comonad"+        , lawContextLawBody = "f =>= extract" `congruency` "f"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "f =>= extract $ x" `congruency` "f x, where"+            , "f = " ++ show f'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++extractLeftIdentity :: forall f. ComonadProp f+extractLeftIdentity fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  f' <- forAll $ genLinearEquationW fgen+  let f = runLinearEquationW f'+  let lhs = extract =>= f $ x+  let rhs = f x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extract Cokleisli Left Identity", lawContextTcName = "Comonad"+        , lawContextLawBody = "extract =>= f" `congruency` "f"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "extract =>= f $ x" `congruency` "f x, where"+            , "f = " ++ show f'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++cokleisliAssociativity :: forall f. ComonadProp f+cokleisliAssociativity fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  f' <- forAll $ genLinearEquationW fgen+  g' <- forAll $ genLinearEquationW fgen+  h' <- forAll $ genLinearEquationW fgen+  let f = runLinearEquationW f'+  let g = runLinearEquationW g'+  let h = runLinearEquationW h'+  let lhs = (f =>= g) =>= h $ x+  let rhs = f =>= (g =>= h) $ x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Cokleisli Associativity", lawContextTcName = "Comonad"+        , lawContextLawBody = "(f =>= g) =>= h" `congruency` "f =>= (g =>= h)"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "(f =>= g) =>= h $ x" `congruency` "f =>= (g =>= h) $ x, where"+            , "f = " ++ show f'+            , "g = " ++ show g'+            , "h = " ++ show h'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx+++extractDuplicateIdentity :: forall f. ComonadProp f+extractDuplicateIdentity fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  let lhs = extract . duplicate $ x+  let rhs = x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extract/Duplicate Identity", lawContextTcName = "Comonad"+        , lawContextLawBody = "extract . duplicate" `congruency` "id"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "extract . duplicate $ x" `congruency` "x, where"+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++fmapExtractDuplicateIdentity :: forall f. ComonadProp f+fmapExtractDuplicateIdentity fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  let lhs = fmap extract . duplicate $ x+  let rhs = x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Fmap Extract/Duplicate Identity", lawContextTcName = "Comonad"+        , lawContextLawBody = "fmap extract . duplicate" `congruency` "id"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "fmap extract . duplicate $ x" `congruency` "x, where"+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++doubleDup :: forall f. ComonadProp f+doubleDup fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  let lhs = duplicate . duplicate $ x+  let rhs = fmap duplicate . duplicate $ x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Double Duplicate", lawContextTcName = "Comonad"+        , lawContextLawBody = "duplicate . duplicate" `congruency` "fmap duplicate . duplicate"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "duplicate . duplicate $ x" `congruency` "fmap duplicate . duplicate $ x, where"+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++extendDuplicate :: forall f. ComonadProp f+extendDuplicate fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  f' <- forAll $ genLinearEquationW fgen+  let f = runLinearEquationW f'+  let lhs = extend f $ x+  let rhs = fmap f . duplicate $ x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Extend/Fmap Duplicate", lawContextTcName = "Comonad"+        , lawContextLawBody = "extend f" `congruency` "fmap f . duplicate"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "extend f x" `congruency` "fmap f . duplicate $ x, where"+            , "f = " ++ show f'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++duplicateExtendId :: forall f. ComonadProp f+duplicateExtendId fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  let lhs = duplicate x+  let rhs = extend id x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Duplicate/Extend Id", lawContextTcName = "Comonad"+        , lawContextLawBody = "duplicate" `congruency` "extend id"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "duplicate x" `congruency` "extend id x, where"+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++fmapExtendExtract :: forall f. ComonadProp f+fmapExtendExtract fgen = property $ do+  x :: f Integer <- forAll $ fgen genSmallInteger+  f' <- forAll genLinearEquation+  let f = runLinearEquation f'+  let lhs = fmap f x+  let rhs = extend (f . extract) x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Fmap/Extend Extract", lawContextTcName = "Comonad"+        , lawContextLawBody = "fmap f" `congruency` "extend (f . extract)"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "fmap f x" `congruency` "extend (f . extract) x, where"+            , "f = " ++ show f'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++fmapLiftW :: forall f. ComonadProp f+fmapLiftW fgen = property $ do+  x <- forAll $ fgen genSmallInteger+  f' <- forAll genLinearEquation+  let f = runLinearEquation f'+  let lhs = fmap f x+  let rhs = liftW f x+  let ctx = contextualise $ LawContext+        { lawContextLawName = "Fmap/LiftW", lawContextTcName = "Comonad"+        , lawContextLawBody = "fmap" `congruency` "liftW"+        , lawContextReduced = reduced lhs rhs+        , lawContextTcProp = lawWhere+            [ "fmap f x" `congruency` "liftW f x, where"+            , "f = " ++ show f'+            , "x = " ++ show x+            ]+        }+  heqCtx lhs rhs ctx++#endif
src/Hedgehog/Classes/Monad.hs view
@@ -71,7 +71,7 @@               [ "m >>= return" `congruency` "m, where"               , "m = " ++ showM               ]-        }  +        }   heqCtx1 lhs rhs ctx  monadAssociativity :: forall f. MonadProp f@@ -115,7 +115,7 @@               [ "return x" `congruency` "pure x, where"               , "x = " ++ showX               ]-        }  +        }   heqCtx1 lhs rhs ctx  monadAp :: forall f. MonadProp f@@ -135,7 +135,7 @@                 showF = show f'             in lawWhere               [ "ap f x" `congruency` "f <*> x, where"-              , "f = " ++ showF +              , "f = " ++ showF               , "x = " ++ showX               ]         }
test/Spec.hs view
@@ -11,6 +11,7 @@ import Spec.Bitraversable import Spec.Bits import Spec.Category+import Spec.Comonad import Spec.Contravariant import Spec.Enum import Spec.Eq@@ -60,6 +61,7 @@ allUnaryLaws :: [(String, [Laws])] allUnaryLaws = testAlternative   ++ testApplicative+  ++ testComonad   ++ testContravariant   ++ testFoldable   ++ testFunctor
test/Spec/Category.hs view
@@ -1,9 +1,26 @@ module Spec.Category (testCategory, testCommutativeCategory) where +import Control.Category+import Hedgehog import Hedgehog.Classes+import Prelude hiding ((.), id)  testCategory :: [(String, [Laws])]-testCategory = []+testCategory =+  [ ("ProxyC", [categoryLaws genProxyC])+  ]  testCommutativeCategory :: [(String, [Laws])]-testCommutativeCategory = []+testCommutativeCategory =+  [ ("ProxyC", [commutativeCategoryLaws genProxyC])+  ]++data ProxyC a b = ProxyC+  deriving (Eq, Show)++instance Category ProxyC where+  id = ProxyC+  _ . _ = ProxyC++genProxyC :: Gen a -> Gen b -> Gen (ProxyC a b)+genProxyC _ _ = pure ProxyC
+ test/Spec/Comonad.hs view
@@ -0,0 +1,54 @@+{-# language+        DerivingStrategies+      , GeneralizedNewtypeDeriving+  #-}++{-# options_ghc -fno-warn-orphans #-}++module Spec.Comonad+  ( testComonad+  ) where++import Data.List.NonEmpty+import Control.Applicative (liftA2)+import Control.Comonad+import Control.Comonad.Store hiding (store)+import Data.Functor.Identity (Identity(..))+import Hedgehog+import Hedgehog.Classes+import Prelude hiding (either)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++testComonad :: [(String, [Laws])]+testComonad =+  [ ("Identity", [comonadLaws identity])+  , ("NonEmpty", [comonadLaws nonempty])+  , ("(,) e", [comonadLaws tup])+  , ("StoreT Integer Identity", [comonadLaws store])+  ]++store :: MonadGen m => m a -> m (StoreT Integer Identity a)+store gen = do+  a <- gen+  pure $ StoreT (Identity (const a)) 20++instance (Comonad w, Show s, Show a) => Show (StoreT s w a) where+  show (StoreT wf s) = show $ "StoreT { s = " ++ show s ++ ", extract stuff = " ++ show (extract wf s) ++ "}"++instance (Comonad w, Eq a) => Eq (StoreT s w a) where+  StoreT wf s == StoreT wf' s' = extract wf s == extract wf' s'++identity :: MonadGen m => m a -> m (Identity a)+identity = fmap Identity++nonempty :: MonadGen m => m a -> m (NonEmpty a)+nonempty gen = liftA2 (:|) gen (list gen)++tup :: MonadGen m => m a -> m (Integer, a)+tup gen = (,)+  <$> Gen.integral (Range.linear 20 50)+  <*> gen++list :: MonadGen m => m a -> m [a]+list = Gen.list $ Range.linear 0 6
test/Spec/Contravariant.hs view
@@ -5,7 +5,7 @@ import Hedgehog import Hedgehog.Classes -import Data.Functor.Contravariant+--import Data.Functor.Contravariant -- lol import Data.Functor.Const (Const(..)) import Data.Functor.Sum (Sum(..)) import Data.Functor.Product (Product(..))@@ -20,7 +20,7 @@   , ("Const", listConst)   , ("Sum", listSum)   , ("Product", listProduct)---  , ("Bad Contravariant", listBadContravariant) +--  , ("Bad Contravariant", listBadContravariant)   ]  listProxy :: [Laws]
test/Spec/Foldable.hs view
@@ -6,9 +6,9 @@ import Data.Set (Set) import qualified Data.Set as Set -import qualified Data.List as List-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+--import qualified Data.List as List+--import qualified Hedgehog.Gen as Gen+--import qualified Hedgehog.Range as Range  testFoldable :: [(String, [Laws])] testFoldable =@@ -24,6 +24,7 @@   x <- gen   pure (Set.singleton x) +{- listBadList :: [Laws] listBadList = [foldableLaws genBadList] @@ -36,3 +37,4 @@ instance Foldable BadList where   foldMap f (BadList x) = foldMap f x   foldl' = List.foldl+-}