free-algebras 0.0.5.1 → 0.0.6.0

raw patch · 13 files changed

+437/−122 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−1
• free-algebras.cabal +7/−12
• src/Control/Algebra/Free.hs +11/−14
• src/Control/Algebra/Free2.hs +127/−0
• src/Data/Algebra/Free.hs +9/−1
• src/Data/Monoid/MSet.hs +55/−50
• src/Data/Semigroup/SSet.hs +12/−11
• test/Main.hs +8/−4
• test/Test/Control/Algebra/Free.hs +12/−17
• test/Test/Data/Algebra/Free.hs +11/−10
• test/Test/Data/Group/Free.hs +2/−2
• test/Test/Data/Monoid/MSet.hs +88/−0
• test/Test/Data/Semigroup/SSet.hs +89/−0

@@ -1,5 +1,11 @@ # Changelog for free-algebras +## Version 0.0.6.0+- `Num a => SSet (Sum a) a` and `Num a => SSet (Product a) a` instances+- `Num a => MSet (Sum a) a` and `Num a => MSet (Product a) a` instances+- removed some overlapping instances for `SSet` and `MSet`+- `Control.Algebra.Free2` module, see `free-category` package for applications.+ ## Version 0.0.5.1 - Improved documentation @@ -28,4 +34,3 @@ - Simplified `Proof` type.  ## Unreleased changes-

@@ -1,5 +1,5 @@ name:           free-algebras-version:        0.0.5.1+version:        0.0.6.0 synopsis:       Free algebras in Haskell. description:    Universal algebra approach to free algebras including higher kinded algebraic structures like functors, applicative functors or monads. category:       Algebra, Control, Monads@@ -21,14 +21,10 @@   type: git   location: https://github.com/coot/free-algebras -flag develop-  description: Set -Werror flag-  manual: True-  default: False- library   exposed-modules:       Control.Algebra.Free+      Control.Algebra.Free2       Control.Monad.Action       Data.Algebra.Free       Data.Algebra.Pointed@@ -55,10 +51,7 @@     , mtl             >= 2.2 && <2.3     , natural-numbers >= 0.1 && <0.2     , transformers    >= 0.5 && <0.6-  if flag(develop)-    ghc-options: -Werror -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-deprecations-  else-    ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-deprecations+  ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-deprecations   default-language: Haskell2010  test-suite free-algebras-test@@ -68,13 +61,15 @@       Test.Control.Algebra.Free       Test.Data.Algebra.Free       Test.Data.Group.Free+      Test.Data.Semigroup.SSet+      Test.Data.Monoid.MSet       Paths_free_algebras   hs-source-dirs:       test   default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleInstances FlexibleContexts KindSignatures InstanceSigs MultiParamTypeClasses OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies-  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall   build-depends:-      base            >= 4.9 && <5+      base            >= 4.9 && < 5     , constraints     , containers     , data-fix

@@ -94,7 +94,7 @@      -- | The freeness property.     foldNatFree-        :: forall (d :: Type -> Type) f a .+        :: forall d f a .            ( AlgebraType  m d            , AlgebraType0 m f            )@@ -134,6 +134,7 @@     => f (m f a)     -> m f a wrapFree = join . liftFree+{-# INLINE wrapFree #-}  -- | -- @'FreeAlgebra1' m@ implies that @m f@ is a foldable.@@ -159,6 +160,7 @@           -> f a foldFree1 = case forget1 @m @f of     Proof Dict -> foldNatFree id+{-# INLINE foldFree1 #-}  -- | -- @'unFoldNatFree'@ is an inverse of @'foldNatFree'@@@ -198,6 +200,7 @@            -> m g a hoistFree1 nat = case codom1 @m @g of     Proof Dict -> foldNatFree (liftFree . nat)+{-# INLINE hoistFree1 #-}  -- | -- @@@ -219,6 +222,7 @@         => m f a         -> n f a hoistFreeH = foldNatFree liftFree+{-# INLINE hoistFreeH #-}  -- | -- @'joinFree1'@ makes @m@ a monad in some subcatgory of types of kind @Type -> Type@@@ -233,6 +237,7 @@ joinFree1 = case codom1 @m @f of     Proof Dict -> case forget1 @m @(m f) of         Proof Dict -> foldFree1+{-# INLINE joinFree1 #-}  -- | -- Bind operator for the @'joinFree1'@ monad, this is just @'foldNatFree'@ in@@ -253,6 +258,7 @@           -> m g a bindFree1 mfa nat = case codom1 @m @g of     Proof Dict -> foldNatFree nat mfa+{-# INLINE bindFree1 #-}  assocFree1 :: forall m f a .               ( FreeAlgebra1 m@@ -265,19 +271,8 @@     Proof Dict -> case codom1 @m @f of         Proof Dict -> case forget1 @m @(m f) of             Proof Dict -> case codom1 @m @(m f) of-                Proof Dict -> case forget1 @m @(m (m f)) of-                    Proof Dict -> fmap g <$> foldNatFree f-    where-        f :: forall x .-             ( AlgebraType0 m f-             , AlgebraType0 m (m f)-             )-          => f x-          -> m (m f) x-        f = hoistFree1 liftFree . liftFree--        g :: m f a -> f a-        g = foldFree1+                Proof Dict -> fmap foldFree1 <$> foldNatFree (hoistFree1 liftFree . liftFree)+{-# INLINE assocFree1 #-}  -- | -- @'Fix' (m f)@ is the initial /algebra/ of type @'AlgebraType' m@ and@@ -307,6 +302,7 @@           -> m f a           -> a iterFree1 f = runIdentity . foldNatFree @_ @Identity (Identity . f)+{-# INLINE iterFree1 #-}  -- Instances @@ -555,6 +551,7 @@  mappend1_ :: MonadList m => a -> a -> m a mappend1_ a b = return a `mappend1` return b+{-# INLINE mappend1_ #-}  instance Monad m => MonadList (ListT m) where     mempty1 = ListT (return [])

@@ -0,0 +1,127 @@+module Control.Algebra.Free2+    ( FreeAlgebra2 (..)+    , Proof (..)+    , proof+    , AlgebraType0+    , AlgebraType+    , wrapFree2+    , foldFree2+    , unFoldNatFree2+    , hoistFree2+    , hoistFreeH2+    , joinFree2+    , bindFree2+    , assocFree2+    ) where++import           Control.Monad (join)+import           Data.Constraint (Dict (..))+import           Data.Kind (Type)++import           Data.Algebra.Free (AlgebraType, AlgebraType0, Proof (..), proof)++-- |+-- Free algebra similar to @'FreeAlgebra1'@ and @'FreeAlgebra'@, but for types+-- of kind @Type -> Type -> Type@.  Examples include free categories, free+-- arrows, etc (see 'free-category' package).+class FreeAlgebra2 (m :: (Type -> Type -> Type) -> Type -> Type -> Type) where+    liftFree2    :: AlgebraType0 m f => f a b -> m f a b+    foldNatFree2 :: forall d f a b .+                    ( AlgebraType  m d+                    , AlgebraType0 m f+                    )+                 => (forall x y. f x y -> d x y)+                 -> (m f a b -> d a b)++    codom2  :: forall f. AlgebraType0 m f => Proof (AlgebraType m (m f)) (m f)+    forget2 :: forall f. AlgebraType  m f => Proof (AlgebraType0 m f) (m f)++wrapFree2 :: forall m f a b .+             ( AlgebraType0 m f+             , FreeAlgebra2 m+             , Monad (m f a)+             )+          => f a (m f a b)+          -> m f a b+wrapFree2 = join . liftFree2+{-# INLINE wrapFree2 #-}++foldFree2 :: forall m f a b .+             ( FreeAlgebra2 m+             , AlgebraType  m f+             )+          => m f a b+          -> f a b+foldFree2 = case forget2 @m @f of+    Proof Dict -> foldNatFree2 id+{-# INLINE foldFree2 #-}++unFoldNatFree2+    :: ( FreeAlgebra2 m+       , AlgebraType0 m f+       )+    => (forall x y. m f x y -> d x y)+    -> f a b -> d a b+unFoldNatFree2 nat = nat . liftFree2+{-# INLINE unFoldNatFree2 #-}++hoistFree2 :: forall m f g a b .+              ( FreeAlgebra2 m+              , AlgebraType0 m g+              , AlgebraType0 m f+              )+           => (forall x y. f x y -> g x y)+           -> m f a b+           -> m g a b+hoistFree2 nat = case codom2 @m @g of+    Proof Dict -> foldNatFree2 (liftFree2 . nat)+{-# INLINE hoistFree2 #-}++hoistFreeH2 :: forall m n f a b .+           ( FreeAlgebra2 m+           , FreeAlgebra2 n+           , AlgebraType0 m f+           , AlgebraType0 n f+           , AlgebraType  m (n f)+           )+        => m f a b+        -> n f a b+hoistFreeH2 = foldNatFree2 liftFree2+{-# INLINE hoistFreeH2 #-}++joinFree2 :: forall m f a b .+             ( FreeAlgebra2 m+             , AlgebraType0 m f+             )+          => m (m f) a b+          -> m f a b+joinFree2 = case codom2 @m @f of+    Proof Dict -> case forget2 @m @(m f) of+        Proof Dict -> foldFree2+{-# INLINE joinFree2 #-}++bindFree2 :: forall m f g a b .+             ( FreeAlgebra2 m+             , AlgebraType0 m g+             , AlgebraType0 m f+             )+          => m f a b+          -> (forall x y . f x y -> m g x y)+          -> m g a b+bindFree2 mfa nat = case codom2 @m @g of+    Proof Dict -> foldNatFree2 nat mfa+{-# INLINE bindFree2 #-}++assocFree2 :: forall m f a b .+              ( FreeAlgebra2 m+              , AlgebraType  m f+              , Functor (m (m f) a)+              )+           => m f a (m f a b)+           -> m (m f) a (f a b)+assocFree2 = case forget2 @m @f of+    Proof Dict -> case codom2 @m @f of+        Proof Dict -> case forget2 @m @(m f) of+            Proof Dict -> case codom2 @m @(m f) of+                Proof Dict -> fmap foldFree2 <$> foldNatFree2 (hoistFree2 liftFree2 . liftFree2)+{-# INLINE assocFree2 #-}

@@ -72,6 +72,7 @@ -- @'Proof'@ smart constructor. proof :: c => Proof (c :: Constraint) (a :: l) proof = Proof Dict+{-# INLINE proof #-}  -- | -- A lawful instance has to guarantee that @'unFoldFree'@ is an inverse of@@ -124,6 +125,7 @@     => (m a -> d)     -> (a -> d) unFoldMapFree f = f . returnFree+{-# INLINE unFoldMapFree #-}  -- | -- All types which satisfy @'FreeAlgebra'@ constraint are foldable.@@ -142,6 +144,7 @@     -> a foldFree ma = case forget @m @a of     Proof Dict -> foldMapFree id ma+{-# INLINE foldFree #-}  -- | -- The canonical quotient map from a free algebra of a wider class to a free@@ -166,6 +169,7 @@         => m a         -> n a natFree = foldMapFree returnFree+{-# INLINE natFree #-}  -- | -- All types which satisfy @'FreeAlgebra'@ constraint are functors.@@ -180,6 +184,7 @@          -> m b fmapFree f ma = case codom @m @b of     Proof Dict -> foldMapFree (returnFree . f) ma+{-# INLINE fmapFree #-}  -- | -- @'FreeAlgebra'@ constraint implies @Monad@ constrain.@@ -191,6 +196,7 @@          -> m a joinFree mma = case codom @m @a of     Proof Dict -> foldFree mma+{-# INLINE joinFree #-}  -- | -- The monadic @'bind'@ operator.  @'returnFree'@ is the corresponding@@ -205,10 +211,12 @@          -> m b bindFree ma f = case codom @m @b of     Proof Dict -> foldMapFree f ma+{-# INLINE bindFree #-}  -- | -- @'Fix' m@ is the initial algebra in the category of algebras of type--- @'AlgebraType' m@, whenever it /exists/.+-- @'AlgebraType' m@ (the initial algebra is a free algebra generated by empty+-- set of generators, e.g. the @Viod@ type). -- -- Another way of putting this is observing that @'Fix' m@ is isomorphic to @m -- Void@ where @m@ is the /free algebra/.  This isomorphisms is given by

@@ -5,11 +5,14 @@     The category of @MSet@s (and @GSet@s) is monadic (unlike the category of @SSet@s).  -} module Data.Monoid.MSet-    ( MSet+    ( MSet (..)     , SSet (..)     , Endo (..)     , rep     , fact+#if __GLASGOW_HASKELL__ < 804+    , fmact+#endif     , FreeMSet (..)     , hoistFreeMSet     , foldrMSet@@ -22,13 +25,17 @@ import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import           Data.List.NonEmpty (NonEmpty)+#if __GLASGOW_HASKELL__ < 804 import qualified Data.List.NonEmpty as NE-import           Data.Monoid (Monoid, Endo (..), Sum (..))+#endif+import           Data.Monoid (Monoid, Endo (..), Sum (..), Product (..)) import           Data.Natural (Natural) import           Data.Ord (Down (..)) import           Data.Semigroup (Semigroup (..)) import           Data.Set (Set)+#if __GLASGOW_HASKELL__ < 804 import qualified Data.Set as Set+#endif  import           Data.Semigroup.SSet (SSet (..), S (..), fact, rep) import           Data.Algebra.Free@@ -52,150 +59,138 @@ -- Note that if @g@ is a @'Group'@ then an @MSet@ is simply a @GSet@, this -- is because monoids and groups share the same morphisms (a monoid homomorphis -- between groups necessarily preserves inverses).-#if __GLASGOW_HASKELL__ > 822-class (Monoid m , SSet m a) => MSet m a-  mact :: m -> a -> a-  mact = act+#if __GLASGOW_HASKELL__ >= 804+class (Monoid m, SSet m a) => MSet m a where+    mact :: m -> a -> a+    mact = act #else class Monoid m => MSet m a where-  mact :: m -> a -> a+    mact :: m -> a -> a #endif -instance Monoid m => MSet m m where-#if __GLASGOW_HASKELL__ <= 822-  mact = mappend+instance {-# OVERLAPPABLE #-} Monoid m => MSet m m where+#if __GLASGOW_HASKELL__ < 804+   mact = mappend #endif  instance (MSet m a, MSet m b) => MSet m (a, b) where-#if __GLASGOW_HASKELL__ <= 822-  mact m (a, b) = (mact m a, mact m b)+#if __GLASGOW_HASKELL__ < 804+    mact m (a, b) = (mact m a, mact m b) #endif  instance (MSet m a, MSet m b, MSet m c) => MSet m (a, b, c) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (a, b, c) = (mact m a, mact m b, mact m c) #endif  instance (MSet m a, MSet m b, MSet m c, MSet m d) => MSet m (a, b, c, d) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (a, b, c, d) = (mact m a, mact m b, mact m c, mact m d) #endif  instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e) => MSet m (a, b, c, d, e) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (a, b, c, d, e) = (mact m a, mact m b, mact m c, mact m d, mact m e) #endif  instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e, MSet m f) => MSet m (a, b, c, d, e, f) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (a, b, c, d, e, f) = (mact m a, mact m b, mact m c, mact m d, mact m e, mact m f) #endif  instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e, MSet m f, MSet m h) => MSet m (a, b, c, d, e, f, h) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (a, b, c, d, e, f, h) = (mact m a, mact m b, mact m c, mact m d, mact m e, mact m f, mact m h) #endif  instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e, MSet m f, MSet m h, MSet m i) => MSet m (a, b, c, d, e, f, h, i) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (a, b, c, d, e, f, h, i) = (mact m a, mact m b, mact m c, mact m d, mact m e, mact m f, mact m h, mact m i) #endif  instance MSet m a => MSet m [a] where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m = map (mact m) #endif  instance MSet m a => MSet m (NonEmpty a) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m = NE.map (mact m) #endif  instance (MSet m a, Ord a) => MSet m (Set a) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m as = Set.map (mact m) as #endif -{---  - instance {-# OVERLAPPABLE #-} (Functor f, MSet m a) => MSet m (f a) where-  -     act m fa = fmap (act m) fa-  --}---#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804 fmact :: (Functor f, MSet s a) => s -> f a -> f a fmact s = fmap (mact s) #endif - instance MSet m a => MSet m (Identity a) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact #endif  instance MSet m a => MSet (Identity m) a where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact (Identity f) a = f `mact` a #endif  instance MSet m a => MSet m (Maybe a) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact #endif  instance MSet m b => MSet m (Either a b) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact #endif  instance MSet m a => MSet m (Down a) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (Down a) =  Down (mact m a) #endif  instance MSet m a => MSet m (IO a) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact #endif  instance MSet m b => MSet m (a -> b) where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact #endif  instance MSet (Endo a) a where-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = appEndo #endif -instance {-# OVERLAPPABLE #-} MSet m a => MSet (S m) a where-#if __GLASGOW_HASKELL__ <= 822-    S m `mact` a = m `mact` a-#endif--instance {-# OVERLAPPING #-} MSet m b => MSet (S m) (Endo b) where-#if __GLASOW_HASKELL__ <= 822-    mact m (Endo f) = Endo $ mact m . f+instance MSet m b => MSet (S m) (Endo b) where+#if __GLASGOW_HASKELL__ < 804+    mact (S m) (Endo f) = Endo $ mact m . f #endif  instance Monoid m => MSet (Sum Natural) m where-#if __GLASOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact (Sum 0) _ = mempty     mact (Sum n) s = s `mappend` mact (Sum (n - 1)) s #endif  instance MSet m a => MSet m (Const a b) where-#if __GLASOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact s (Const a) = Const $ s `mact` a #endif  instance (Functor f, Functor h, MSet m a) => MSet m (Functor.Product f h a) where-#if __GLASOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact  #endif  instance (Functor f, Functor h, MSet m a) => MSet m (Functor.Sum f h a) where-#if __GLASOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact = fmact  #endif @@ -221,8 +216,18 @@     act m (FreeMSet (h, a)) = FreeMSet (m <> h, a)  instance Monoid m => MSet m (FreeMSet m a) where-#if __GLASOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     mact m (FreeMSet (h, a)) = FreeMSet (m `mappend` h, a)+#endif++instance Num s => MSet (Sum s) s where+#if __GLASGOW_HASKELL__ < 804+    mact (Sum n) s = n + s+#endif++instance Num s => MSet (Product s) s where+#if __GLASGOW_HASKELL__ < 804+    mact (Product n) s = n * s #endif  -- |

@@ -9,7 +9,7 @@     , S (..)     ) where -import           Data.Semigroup (Semigroup (..), Endo (..), Sum (..))+import           Data.Semigroup (Semigroup (..), Endo (..), Sum (..), Product (..)) import           Data.Functor.Const (Const (..)) import           Data.Functor.Identity (Identity (..)) import qualified Data.Functor.Product as Functor (Product)@@ -39,7 +39,7 @@ rep :: SSet s a => s -> Endo a rep s = Endo (act s) -instance {-# OVERLAPPING #-} Semigroup s => SSet s s where+instance {-# OVERLAPPABLE #-} Semigroup s => SSet (s) (s) where     act = (<>)  instance (SSet s a, SSet s b) => SSet s (a, b) where@@ -104,24 +104,19 @@ -- | -- A newtype wrapper to avoid overlapping instances. newtype S s = S { runS :: s }+  deriving (Eq, Show, Ord)  instance Semigroup m => Semigroup (S m) where     S s <> S s' = S $ s <> s'  instance Monoid m => Monoid (S m) where     mempty = S mempty-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ < 804     S s `mappend` S s' = S $ s `mappend` s' #endif --- instance {-# OVERLAPPABLE #-} SSet m a => SSet (S m) a where-    -- act (S m) a = act m a---- instance {-# OVERLAPPABLE #-} SSet s a => SSet (S s) (Endo a) where-    -- act s (Endo f) = Endo $ act s . f--instance {-# OVERLAPPABLE #-} SSet s a => SSet s (Endo a) where-    act s (Endo f) = Endo $ act s . f+instance SSet s a => SSet (S s) (Endo a) where+    act (S s) (Endo f) = Endo $ act s . f  instance Monoid s => SSet (Sum Natural) s where     act (Sum 0) _ = mempty@@ -140,3 +135,9 @@  instance (Functor f, Functor h, SSet s a) => SSet s (Functor.Sum f h a) where     act = fact++instance Num s => SSet (Sum s) s where+    act (Sum n) s = n + s++instance Num s => SSet (Product s) s where+    act (Product n) s = n * s

@@ -5,9 +5,11 @@ import           Control.Monad (unless) import           System.Exit (exitFailure) -import qualified Test.Data.Group.Free (tests)-import qualified Test.Data.Algebra.Free (tests) import qualified Test.Control.Algebra.Free (tests)+import qualified Test.Data.Algebra.Free (tests)+import qualified Test.Data.Group.Free (tests)+import qualified Test.Data.Semigroup.SSet (tests)+import qualified Test.Data.Monoid.MSet (tests)  runTests :: [IO Bool] -> IO () runTests tests = do@@ -18,7 +20,9 @@ main :: IO () main = do     runTests-        [ Test.Data.Algebra.Free.tests-        , Test.Control.Algebra.Free.tests+        [ Test.Control.Algebra.Free.tests+        , Test.Data.Algebra.Free.tests         , Test.Data.Group.Free.tests+        , Test.Data.Semigroup.SSet.tests+        , Test.Data.Monoid.MSet.tests         ]

@@ -8,12 +8,8 @@ import qualified Control.Applicative.Free as Ap import           Control.Monad.Free (Free) import qualified Control.Monad.Free as Free-import           Control.Monad (join)-import           Data.List.NonEmpty (NonEmpty (..))-import           Data.Foldable (fold) import           Data.Functor.Identity (Identity (..)) import           Data.Functor.Coyoneda (Coyoneda (..), lowerCoyoneda)-import           Data.Monoid (Sum (..)) import           Data.Proxy (Proxy (..)) import           Hedgehog (Property, PropertyT, Gen, property, (===)) import qualified Hedgehog as H@@ -49,7 +45,7 @@         True  -> return $ Coyoneda id (f a)         False -> do             x <- Gen.int $ Range.linear 0 100 -            return $ Coyoneda (\x -> x + a) (f x)+            return $ Coyoneda (\y -> y + a) (f x)  toOdd :: Integral n => n -> Maybe n toOdd x = if x `mod` 2 == 0@@ -58,7 +54,7 @@  -- | -- Generated `Ap Maybe` with arbitrary depth.-genAp :: forall f x . Show x+genAp :: forall x . Show x       => Gen x       -> Gen (x -> x)       -> Gen (Ap Maybe x)@@ -73,7 +69,7 @@         return $ Ap.Pure f <*> ap  genApIdentity-    :: forall f x . Show x+    :: forall x . Show x     => Gen x     -> Gen (x -> x)     -> Gen (Ap Identity x)@@ -127,20 +123,18 @@         H.assert $ fd_id (Proxy :: Proxy m) fd fa == fd fa         H.assert $ mfd_id mfd mfa == mfd mfa     where-    fd_id :: forall a-          .  Proxy m+    fd_id :: Proxy m           -> (forall x. f x -> d x)           -> (forall x. f x -> d x)     fd_id _ nat =-        let nat' :: forall a . m f a -> d a+        let nat' :: forall y . m f y -> d y             nat' = foldNatFree nat         in unFoldNatFree nat' -    mfd_id :: forall a-           .  (forall x. m f x -> d x)+    mfd_id :: (forall x. m f x -> d x)            -> (forall x. m f x -> d x)     mfd_id nat =-        let nat' :: forall a . f a -> d a+        let nat' :: forall y . f y -> d y             nat' = unFoldNatFree nat         in foldNatFree nat' @@ -148,11 +142,12 @@ prop_foldMapFree1_coyoneda     = foldMapFree1_property         (genCoyoneda toOdd)-        (Gen.maybe $ Gen.integral (Range.linear 0 1000))+        (Gen.maybe $ Gen.integral @_ @Int (Range.linear 0 1000))         id         foldFree1  prop_foldMapFree1_ap :: Property+prop_foldMapFree1_ap     = foldMapFree1_property         (genAp (Gen.word8 (Range.linear 0 254)) genIntToInt)         (Gen.maybe $ Gen.word8 (Range.linear 0 254))@@ -189,12 +184,12 @@  prop_foldFree1_ap :: Property prop_foldFree1_ap = foldFree1_property-    (H.forAllWith (show . Ap.retractAp) $ genAp (Gen.integral $ Range.linear 0 100) genIntToInt)+    (H.forAllWith (show . Ap.retractAp) $ genAp (Gen.integral @_ @Int $ Range.linear 0 100) genIntToInt)     Ap.retractAp  prop_foldFree1_free :: Property prop_foldFree1_free = foldFree1_property-    (H.forAll $ genFree (Gen.integral $ Range.linear 0 100))+    (H.forAll $ genFree (Gen.integral @_ @Int $ Range.linear 0 100))     (Free.foldFree id)  hoistFree1_property@@ -235,7 +230,7 @@  prop_hoistFree1_free :: Property prop_hoistFree1_free = hoistFree1_property-    (genFree (Gen.integral $ Range.linear 0 100))+    (genFree (Gen.integral @_ @Int $ Range.linear 0 100))     show     (==)     (maybe (Left ()) Right)

@@ -103,15 +103,16 @@     = foldMapFree_property @[] @(Sum Int) @Int         ((Gen.list $ Range.linear 0 100)             (Gen.integral $ Range.linear 0 1024))-        (Gen.integral $ Range.linear 0 1024)+        (Gen.integral @_ @Int $ Range.linear 0 1024)         (Sum . sum)         Sum  prop_foldMapFree_nonempty :: Property+prop_foldMapFree_nonempty     = foldMapFree_property @NonEmpty @(Sum Int) @Int         ((Gen.nonEmpty $ Range.linear 0 100)-            (Gen.integral $ Range.linear 0 1024))-        (Gen.integral $ Range.linear 0 1024)+            (Gen.integral @_ @Int $ Range.linear 0 1024))+        (Gen.integral @_ @Int $ Range.linear 0 1024)         (Sum . sum)         Sum @@ -140,13 +141,13 @@ prop_fmapFree_list = fmapFree_property @[] @Integer @Integer     ((Gen.list $ Range.linear 0 100)         (Gen.integral $ Range.linear 0 1024))-    (\x -> x^2 + 2 * x + 1)+    (\x -> x^(2::Int) + 2 * x + 1)  prop_fmapFree_nonempty :: Property prop_fmapFree_nonempty = fmapFree_property     ((Gen.nonEmpty $ Range.linear 0 100)-        (Gen.integral $ Range.linear 0 1024))-    (\x -> x^2 + 2 * x + 1)+        (Gen.integral @_ @Int $ Range.linear 0 1024))+    (\x -> x^(2::Int) + 2 * x + 1)  -- | -- @'joinFree'@ should be equal to @'join'@ for monads.@@ -206,15 +207,15 @@ prop_bindFree_list =     let gen = Gen.list             (Range.linear 0 10)-            (Gen.integral $ Range.linear 0 1024)-    in bindFree_property gen (\x -> [x^2, 2 * x, 1])+            (Gen.integral @_ @Int $ Range.linear 0 1024)+    in bindFree_property gen (\x -> [x^(2 :: Int), 2 * x, 1])  prop_bindFree_nonempty :: Property prop_bindFree_nonempty =     let gen = Gen.nonEmpty             (Range.linear 0 10)-            (Gen.integral $ Range.linear 0 1024)-    in bindFree_property gen (\x -> x^2 :| [2 * x, 1])+            (Gen.integral @_ @Int $ Range.linear 0 1024)+    in bindFree_property gen (\x -> x^(2 :: Int) :| [2 * x, 1])  tests :: IO Bool tests = H.checkParallel $$(H.discover)

@@ -8,12 +8,12 @@ import           Data.Group (invert) import           Data.DList (DList) import qualified Data.DList as DList-import           Hedgehog (Property, PropertyT, Gen, property, (===))+import           Hedgehog (Property, Gen, property, (===)) import qualified Hedgehog as H import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import           Data.Group.Free (FreeGroup, fromDList, normalize)+import           Data.Group.Free (fromDList, normalize)  genDList :: Gen a -> Gen (DList (Either a a)) genDList gen = do

@@ -0,0 +1,88 @@+{-# LANGUAGE TemplateHaskell #-}+module Test.Data.Monoid.MSet+    ( tests+    ) where++import Data.Functor.Identity+import Data.Monoid++import Data.Monoid.MSet++import           Hedgehog (Property, Gen, property, (===))+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++mset_property :: forall m a.+                 ( Monoid m+                 , MSet m a+                 , Show a+                 , Eq a+                 )+              => Gen m+              -> (m -> String)+              -> Gen a+              -> Property+mset_property gens show_ gena = property $ do+  s1 <- H.forAllWith show_ gens+  s2 <- H.forAllWith show_ gens+  a  <- H.forAll gena++  s1 `mact` (s2 `mact` a) === (s1 <> s2) `mact` a+  mempty @m `mact` a === a++prop_mset_sum_int :: Property+prop_mset_sum_int =+  let gens :: Gen (S (Sum Int))+      gens = S . Sum <$> Gen.integral (Range.linear (-1024) 1024)+  in mset_property gens show gens++prop_mset_sum_functor :: Property+prop_mset_sum_functor =+  let gens :: Gen (Sum Int)+      gens = Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen (Identity Int)+      gena = Identity <$> Gen.integral (Range.linear (-1024) 1024)+  in mset_property gens show gena++prop_mset_endo :: Property+prop_mset_endo =+  let gens :: Gen (Endo (Sum Int))+      gens = Endo . (<>) . Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen (Sum Int)+      gena = Sum <$> Gen.integral (Range.linear (-1024) 1024)+  in mset_property gens (const "*") gena++prop_mset_s_sum_int :: Property+prop_mset_s_sum_int =+  let gens :: Gen (Sum Int)+      gens = Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen Int+      gena = Gen.integral (Range.linear (-1024) 1024)+  in mset_property gens show gena++prop_mset_endo2 :: Property+prop_mset_endo2 =+  let gens :: Gen (S (Sum Int))+      gens = S . Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen (Endo Int)+      gena = Endo . (+) <$> Gen.integral (Range.linear (-1024) 1024)+      genb :: Gen Int+      genb = Gen.integral (Range.linear (-1024) 1024)+  in property $ do+    s1 <- H.forAll gens+    s2 <- H.forAll gens+    a  <- H.forAllWith (const "") gena+    b  <- H.forAll genb+    act (s1 <> s2) a `appEndo` b === act s1 (act s2 a) `appEndo` b++prop_mset_product :: Property+prop_mset_product =+  let gens :: Gen (Product Int)+      gens = Product <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen Int+      gena = Gen.integral (Range.linear (-1024) 1024)+  in mset_property gens show gena++tests :: IO Bool+tests = H.checkParallel $$(H.discover)

@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Data.Semigroup.SSet+    ( tests+    ) where++import Data.Functor.Identity+import Data.Semigroup++import Data.Semigroup.SSet++import           Hedgehog (Property, Gen, property, (===))+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++sset_property :: ( Semigroup s+                 , SSet s a+                 , Show a+                 , Eq a+                 )+              => Gen s+              -> (s -> String)+              -> Gen a+              -> Property+sset_property gens show_ gena = property $ do+  s1 <- H.forAllWith show_ gens+  s2 <- H.forAllWith show_ gens+  a  <- H.forAll gena+  s1 `act` (s2 `act` a) === (s1 <> s2) `act` a++prop_sset_sum_int :: Property+prop_sset_sum_int =+  let gens :: Gen (S (Sum Int))+      gens = S . Sum <$> Gen.integral (Range.linear (-1024) 1024)+  in sset_property gens show gens++_s2 :: Identity (S (Sum Int))+_s2 = act @(S (Sum Int)) (S (Sum 1)) (Identity (S (Sum 2)))++prop_sset_sum_functor :: Property+prop_sset_sum_functor =+  let gens :: Gen (Sum Int)+      gens = Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen (Identity Int)+      gena = Identity <$> Gen.integral (Range.linear (-1024) 1024)+  in sset_property gens show gena++prop_sset_endo :: Property+prop_sset_endo =+  let gens :: Gen (Endo (Sum Int))+      gens = Endo . (<>) . Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen (Sum Int)+      gena = Sum <$> Gen.integral (Range.linear (-1024) 1024)+  in sset_property gens (const "*") gena++prop_sset_s_sum_int :: Property+prop_sset_s_sum_int =+  let gens :: Gen (Sum Int)+      gens = Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen Int+      gena = Gen.integral (Range.linear (-1024) 1024)+  in sset_property gens show gena++prop_sset_endo2 :: Property+prop_sset_endo2 =+  let gens :: Gen (S (Sum Int))+      gens = S . Sum <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen (Endo Int)+      gena = Endo . (+) <$> Gen.integral (Range.linear (-1024) 1024)+      genb :: Gen Int+      genb = Gen.integral (Range.linear (-1024) 1024)+  in property $ do+    s1 <- H.forAll gens+    s2 <- H.forAll gens+    a  <- H.forAllWith (const "") gena+    b  <- H.forAll genb+    act (s1 <> s2) a `appEndo` b === act s1 (act s2 a) `appEndo` b++prop_sset_product :: Property+prop_sset_product =+  let gens :: Gen (Product Int)+      gens = Product <$> Gen.integral (Range.linear (-1024) 1024)+      gena :: Gen Int+      gena = Gen.integral (Range.linear (-1024) 1024)+  in sset_property gens show gena++tests :: IO Bool+tests = H.checkParallel $$(H.discover)