free-algebras 0.0.6.0 → 0.0.7.0

raw patch · 13 files changed

+110/−617 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/−0
• README.md +1/−1
• free-algebras.cabal +47/−10
• src/Control/Algebra/Free.hs +19/−14
• src/Control/Algebra/Free2.hs +31/−19
• src/Control/Monad/Action.hs +3/−1
• src/Data/Group/Free.hs +2/−2
• src/Data/Monoid/Abelian.hs +1/−1
• src/Data/Monoid/MSet.hs +0/−245
• src/Data/Semigroup/SSet.hs +0/−143
• test/Main.hs +0/−4
• test/Test/Data/Monoid/MSet.hs +0/−88
• test/Test/Data/Semigroup/SSet.hs +0/−89

@@ -1,5 +1,11 @@ # Changelog for free-algebras +## Version 0.0.7.0+- Poly kinded `Control.Algebra.Free.FreeAlgebra` and+  `Control.Algebra.Free2.FreeAlgebra2`+- removed actions (MSet, SSet), use `monoid-extras` or `semigroups-actions`+  packages+ ## 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

@@ -1,6 +1,6 @@ # Free Algebras [![Maintainer: coot](https://img.shields.io/badge/maintainer-coot-lightgrey.svg)](http://github.com/coot)-[![Travis Build Status](https://travis-ci.org/coot/free-algebras.svg?branch=master)](https://travis-ci.org/coot/free-algebras)+[![CircleCI](https://circleci.com/gh/coot/free-algebras/tree/master.svg?style=svg)](https://circleci.com/gh/coot/free-algebras/tree/master)  Universal algebra approach (which is compatible with categorical approach) to free algebras (including higher order structures like functors, applicative

@@ -1,5 +1,5 @@ name:           free-algebras-version:        0.0.6.0+version:        0.0.7.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@@ -15,7 +15,7 @@ extra-source-files:     ChangeLog.md     README.md-tested-with:    GHC==8.0.2, GHC==8.2.2, GHC==8.4.3+tested-with:    GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1  source-repository head   type: git@@ -30,15 +30,29 @@       Data.Algebra.Pointed       Data.Group.Free       Data.Monoid.Abelian-      Data.Monoid.MSet       Data.Semigroup.Abelian       Data.Semigroup.SemiLattice-      Data.Semigroup.SSet   other-modules:       Paths_free_algebras   hs-source-dirs:       src-  default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleInstances FlexibleContexts KindSignatures InstanceSigs MultiParamTypeClasses OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies+  default-extensions:+      ConstraintKinds+      DataKinds+      DeriveFunctor+      EmptyDataDecls+      FlexibleInstances+      FlexibleContexts+      KindSignatures+      InstanceSigs+      MultiParamTypeClasses+      OverloadedStrings+      PolyKinds+      RankNTypes+      ScopedTypeVariables+      TupleSections+      TypeApplications+      TypeFamilies   build-depends:       base            >= 4.9 && <5     , constraints     >= 0.8 && <0.11.0 @@ -51,7 +65,12 @@     , mtl             >= 2.2 && <2.3     , natural-numbers >= 0.1 && <0.2     , transformers    >= 0.5 && <0.6-  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@@ -61,13 +80,31 @@       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 -Wall+  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+      -Wall   build-depends:       base            >= 4.9 && < 5     , constraints

@@ -49,7 +49,7 @@ import           Control.Monad.State.Class (MonadState (..)) import qualified Control.Monad.State.Lazy as L (StateT (..)) import qualified Control.Monad.State.Strict as S (StateT (..))-import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.Class (MonadTrans (..)) import           Control.Monad.Trans.Maybe (MaybeT (..)) import           Control.Monad.Writer.Class (MonadWriter (..)) import qualified Control.Monad.Writer.Lazy as L (WriterT (..))@@ -88,7 +88,7 @@ -- * @MFunctor@ via @hoist = hoistFree1@ -- * @MMonad@ via @embed = flip bindFree1@ -- * @MonadTrans@ via @lift = liftFree@-class FreeAlgebra1 (m :: (Type -> Type) -> Type -> Type) where+class FreeAlgebra1 (m :: (k -> Type) -> k -> Type) where     -- | Natural transformation that embeds generators into @m@.     liftFree :: AlgebraType0 m f => f a -> m f a @@ -127,7 +127,10 @@ -- The @'Monad'@ constrain will be satisfied for many monads through the -- @'AlgebraType m'@ constraint. wrapFree-    :: ( FreeAlgebra1 m+    :: forall (m :: (Type -> Type) -> Type -> Type)+              (f :: Type -> Type) +              a .+       ( FreeAlgebra1 m        , AlgebraType0 m f        , Monad (m f)        )@@ -158,7 +161,7 @@              )           => m f a           -> f a-foldFree1 = case forget1 @m @f of+foldFree1 = case forget1 :: Proof (AlgebraType0 m f) (m f) of     Proof Dict -> foldNatFree id {-# INLINE foldFree1 #-} @@ -198,7 +201,7 @@            => (forall x. f x -> g x) -- ^ a natural transformation @f ~> g@            -> m f a            -> m g a-hoistFree1 nat = case codom1 @m @g of+hoistFree1 nat = case codom1 :: Proof (AlgebraType m (m g)) (m g) of     Proof Dict -> foldNatFree (liftFree . nat) {-# INLINE hoistFree1 #-} @@ -234,8 +237,8 @@              )           => m (m f) a           -> m f a-joinFree1 = case codom1 @m @f of-    Proof Dict -> case forget1 @m @(m f) of+joinFree1 = case codom1 :: Proof (AlgebraType m (m f)) (m f) of+    Proof Dict -> case forget1 :: Proof (AlgebraType0 m (m f)) (m (m f)) of         Proof Dict -> foldFree1 {-# INLINE joinFree1 #-} @@ -256,7 +259,7 @@           => m f a           -> (forall x . f x -> m g x) -- ^ natural transformation @f ~> m g@           -> m g a-bindFree1 mfa nat = case codom1 @m @g of+bindFree1 mfa nat = case codom1 :: Proof (AlgebraType m (m g)) (m g) of     Proof Dict -> foldNatFree nat mfa {-# INLINE bindFree1 #-} @@ -267,10 +270,10 @@               )            => m f (m f a)            -> m (m f) (f a)-assocFree1 = case forget1 @m @f of-    Proof Dict -> case codom1 @m @f of-        Proof Dict -> case forget1 @m @(m f) of-            Proof Dict -> case codom1 @m @(m f) of+assocFree1 = case forget1 :: Proof (AlgebraType0 m f) (m f) of+    Proof Dict -> case codom1 :: Proof (AlgebraType m (m f)) (m f) of+        Proof Dict -> case forget1 :: Proof (AlgebraType0 m (m f)) (m (m f)) of+            Proof Dict -> case codom1 :: Proof (AlgebraType m (m (m f))) (m (m f)) of                 Proof Dict -> fmap foldFree1 <$> foldNatFree (hoistFree1 liftFree . liftFree) {-# INLINE assocFree1 #-} @@ -301,7 +304,7 @@           => (forall x . f x -> x)           -> m f a           -> a-iterFree1 f = runIdentity . foldNatFree @_ @Identity (Identity . f)+iterFree1 f = runIdentity . foldNatFree (Identity . f) {-# INLINE iterFree1 #-}  -- Instances@@ -483,11 +486,13 @@ -- | -- Algebras of the same type as @'L.ReaderT'@ monad is the class of all reader -- monads.+--+-- TODO: take advantage of poly-kinded `ReaderT` type instance AlgebraType0 (ReaderT r) m = ( Monad m ) type instance AlgebraType  (ReaderT r) m = ( MonadReader r m ) -- | -- @'ReaderT'@ is a free monad in the class of all @'MonadReader'@ monads.-instance FreeAlgebra1 (ReaderT r) where+instance FreeAlgebra1 (ReaderT r :: (Type -> Type) -> Type -> Type) where     liftFree = lift     foldNatFree nat (ReaderT g) =         ask >>= nat . g

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} module Control.Algebra.Free2     ( FreeAlgebra2 (..)     , Proof (..)@@ -24,19 +25,19 @@ -- 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+class FreeAlgebra2 (m :: (k -> k -> Type) -> k -> k -> Type) where     liftFree2    :: AlgebraType0 m f => f a b -> m f a b-    foldNatFree2 :: forall d f a b .+    foldNatFree2 :: forall (d :: k -> k -> Type) (f :: k -> k -> Type) 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)+    codom2  :: forall (f :: k -> k -> Type). AlgebraType0 m f => Proof (AlgebraType m (m f)) (m f)+    forget2 :: forall (f :: k -> k -> Type). AlgebraType  m f => Proof (AlgebraType0 m f) (m f) -wrapFree2 :: forall m f a b .+wrapFree2 :: forall (m :: (Type -> Type -> Type) -> Type -> Type -> Type) (f :: Type -> Type -> Type) a b .              ( AlgebraType0 m f              , FreeAlgebra2 m              , Monad (m f a)@@ -46,18 +47,23 @@ wrapFree2 = join . liftFree2 {-# INLINE wrapFree2 #-} -foldFree2 :: forall m f a b .+foldFree2 :: forall (m :: (k -> k -> Type) -> k -> k -> Type)+                    (f :: k -> k -> Type)+                    a b .              ( FreeAlgebra2 m              , AlgebraType  m f              )           => m f a b           -> f a b-foldFree2 = case forget2 @m @f of+foldFree2 = case forget2 :: Proof (AlgebraType0 m f) (m f) of     Proof Dict -> foldNatFree2 id {-# INLINE foldFree2 #-}  unFoldNatFree2-    :: ( FreeAlgebra2 m+    :: forall (m :: (k -> k -> Type) -> k -> k -> Type)+              (f :: k -> k -> Type)+              d a b.+       ( FreeAlgebra2 m        , AlgebraType0 m f        )     => (forall x y. m f x y -> d x y)@@ -65,7 +71,9 @@ unFoldNatFree2 nat = nat . liftFree2 {-# INLINE unFoldNatFree2 #-} -hoistFree2 :: forall m f g a b .+hoistFree2 :: forall (m :: (k -> k -> Type) -> k -> k -> Type)+                     (f :: k -> k -> Type)+                     g a b .               ( FreeAlgebra2 m               , AlgebraType0 m g               , AlgebraType0 m f@@ -73,7 +81,7 @@            => (forall x y. f x y -> g x y)            -> m f a b            -> m g a b-hoistFree2 nat = case codom2 @m @g of+hoistFree2 nat = case codom2 :: Proof (AlgebraType m (m g)) (m g) of     Proof Dict -> foldNatFree2 (liftFree2 . nat) {-# INLINE hoistFree2 #-} @@ -89,14 +97,16 @@ hoistFreeH2 = foldNatFree2 liftFree2 {-# INLINE hoistFreeH2 #-} -joinFree2 :: forall m f a b .+joinFree2 :: forall (m :: (k -> k -> Type) -> k -> k -> Type)+                    (f :: k -> k -> Type)+                    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+joinFree2 = case codom2 :: Proof (AlgebraType m (m f)) (m f) of+    Proof Dict -> case forget2 :: Proof (AlgebraType0 m (m f)) (m (m f)) of         Proof Dict -> foldFree2 {-# INLINE joinFree2 #-} @@ -108,20 +118,22 @@           => 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+bindFree2 mfa nat = case codom2 :: Proof (AlgebraType m (m g)) (m g) of     Proof Dict -> foldNatFree2 nat mfa {-# INLINE bindFree2 #-} -assocFree2 :: forall m f a b .+assocFree2 :: forall (m :: (Type -> Type -> Type) -> Type -> Type -> Type)+                     (f :: Type -> Type -> Type)+                     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+assocFree2 = case forget2 :: Proof (AlgebraType0 m f) (m f) of+    Proof Dict -> case codom2 :: Proof (AlgebraType m (m f)) (m f) of+        Proof Dict -> case forget2 :: Proof (AlgebraType0 m (m f)) (m (m f)) of+            Proof Dict -> case codom2 :: Proof (AlgebraType m (m (m f))) (m (m f)) of                 Proof Dict -> fmap foldFree2 <$> foldNatFree2 (hoistFree2 liftFree2 . liftFree2) {-# INLINE assocFree2 #-}

@@ -4,6 +4,7 @@  import           Control.Monad (join) import           Data.Functor.Const (Const (..))+import           Data.Kind (Type)  import           Control.Algebra.Free     ( AlgebraType0@@ -50,7 +51,8 @@  -- | -- Free algebra associated with the @'MAction' constraint.-newtype FreeMAction m f a = FreeMAction { runFreeMAction :: m (f a) }+newtype FreeMAction (m :: Type -> Type) (f :: Type -> Type) a =+    FreeMAction { runFreeMAction :: m (f a) }     deriving (Show, Eq, Ord, Functor)  instance (Monad m, Functor f) => MAction m (FreeMAction m f) where

@@ -92,7 +92,7 @@  instance Eq a => Monoid (FreeGroup a) where     mempty = FreeGroup DList.empty-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ <= 802     mappend = (<>) #endif @@ -138,7 +138,7 @@  instance Eq a => Monoid (FreeGroupL a) where     mempty = FreeGroupL []-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ <= 802     mappend = (<>) #endif 

@@ -24,7 +24,7 @@  instance Ord a => Monoid (FreeAbelianMonoid a) where     mempty = FreeAbelianMonoid Map.empty-#if __GLASGOW_HASKELL__ <= 822+#if __GLASGOW_HASKELL__ <= 802     mappend = (<>) #endif 

@@ -1,245 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE DeriveFunctor #-}-{- |-    Monoid and [group actions](https://en.wikipedia.org/wiki/Group_action) (M-Sets and G-Sets).-    The category of @MSet@s (and @GSet@s) is monadic (unlike the category of @SSet@s).- -}-module Data.Monoid.MSet-    ( MSet (..)-    , SSet (..)-    , Endo (..)-    , rep-    , fact-#if __GLASGOW_HASKELL__ < 804-    , fmact-#endif-    , FreeMSet (..)-    , hoistFreeMSet-    , foldrMSet-    , S (..)-    ) where--import           Control.Monad (ap)-import           Data.Functor.Const (Const (..))-import           Data.Functor.Identity (Identity (..))-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-#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-    ( AlgebraType-    , AlgebraType0-    , FreeAlgebra (..)-    , proof-    , bindFree-    , foldrFree-    )---- |--- Lawful instance should satisfy:------ prop> act mempty = id--- prop> g `act` h `act` a = g <> h `act` a------ This is the same as to say that `act` is a monoid homomorphism from @m@ to--- the monoid of endomorphisms of @a@ (i.e. maps from @a@ to @a@).------ 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__ >= 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-#endif--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__ < 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__ < 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__ < 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__ < 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__ < 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__ < 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__ < 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__ < 804-    mact m = map (mact m)-#endif--instance MSet m a => MSet m (NonEmpty a) where-#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__ < 804-    mact m as = Set.map (mact m) as-#endif--#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__ < 804-    mact = fmact-#endif--instance MSet m a => MSet (Identity m) a where-#if __GLASGOW_HASKELL__ < 804-    mact (Identity f) a = f `mact` a-#endif--instance MSet m a => MSet m (Maybe a) where-#if __GLASGOW_HASKELL__ < 804-    mact = fmact-#endif--instance MSet m b => MSet m (Either a b) where-#if __GLASGOW_HASKELL__ < 804-    mact = fmact-#endif--instance MSet m a => MSet m (Down a) where-#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__ < 804-    mact = fmact-#endif--instance MSet m b => MSet m (a -> b) where-#if __GLASGOW_HASKELL__ < 804-    mact = fmact-#endif--instance MSet (Endo a) a where-#if __GLASGOW_HASKELL__ < 804-    mact = appEndo-#endif--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 __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 __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 __GLASGOW_HASKELL__ < 804-    mact = fmact -#endif--instance (Functor f, Functor h, MSet m a) => MSet m (Functor.Sum f h a) where-#if __GLASGOW_HASKELL__ < 804-    mact = fmact -#endif--newtype FreeMSet m a = FreeMSet { runFreeMSet :: (m, a) }-    deriving (Show, Ord, Eq, Functor)--hoistFreeMSet-    :: (m -> n)       -- ^ monoid homomorphism-    -> FreeMSet m a-    -> FreeMSet n a-hoistFreeMSet f (FreeMSet (m, a)) = FreeMSet (f m, a)--instance Monoid m => Applicative (FreeMSet m) where-    pure  = returnFree-    (<*>) = ap--instance ( Monoid m-         ) => Monad (FreeMSet m) where-    return = returnFree-    (>>=)  = bindFree--instance Semigroup m => SSet m (FreeMSet m a) where-    act m (FreeMSet (h, a)) = FreeMSet (m <> h, a)--instance Monoid m => MSet m (FreeMSet m a) where-#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---- |--- @'foldrFree'@ for @'FreeMSet'@-foldrMSet :: forall m a b . MSet m b => (a -> b -> b) -> b -> (m, a) -> b-foldrMSet f b (m, a) = foldrFree f b (FreeMSet (S m, a))--type instance AlgebraType0 (FreeMSet m) a = ()-type instance AlgebraType  (FreeMSet m) a = MSet m a-instance ( Monoid m-         ) => FreeAlgebra (FreeMSet m) where-    returnFree a = FreeMSet (mempty, a)-    foldMapFree f (FreeMSet (m, a)) = mact m (f a)-    codom  = proof-    forget = proof

@@ -1,143 +0,0 @@-{-# LANGUAGE CPP #-}-{- |-    Actions of [semigroup](https://en.wikipedia.org/wiki/Semigroup_action) (SSet).- -}-module Data.Semigroup.SSet-    ( SSet (..)-    , rep-    , fact-    , S (..)-    ) where--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)-import qualified Data.Functor.Sum as Functor (Sum)-import           Data.Group (Group (..))-import           Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NE-import           Data.Natural (Natural)-import           Data.Ord (Down (..))-import           Data.Set (Set)-import qualified Data.Set as Set---- |--- A lawful instance should satisfy:------ prop> g `act` h `act` a = g <> h `act` a------ This is the same as to say that `act` is a semigroup homomorphism from @s@ to--- the monoid of endomorphisms of @a@ (i.e. maps from @a@ to @a@).------ Note that if @g@ is a @'Group'@ then @'MAct' g@ is simply a @GSet@, this--- is because monoids and groups share the same morphisms (a monoid homomorphis--- between groups necessarily preserves inverses).-class Semigroup s => SSet s a where-    act :: s -> a -> a--rep :: SSet s a => s -> Endo a-rep s = Endo (act s)--instance {-# OVERLAPPABLE #-} Semigroup s => SSet (s) (s) where-    act = (<>)--instance (SSet s a, SSet s b) => SSet s (a, b) where-    act s (a, b) = (act s a, act s b)--instance (SSet s a, SSet s b, SSet s c) => SSet s (a, b, c) where-    act s (a, b, c) = (act s a, act s b, act s c)--instance (SSet s a, SSet s b, SSet s c, SSet s d) => SSet s (a, b, c, d) where-    act s (a, b, c, d) = (act s a, act s b, act s c, act s d)--instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e) => SSet s (a, b, c, d, e) where-    act s (a, b, c, d, e) = (act s a, act s b, act s c, act s d, act s e)--instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e, SSet s f) => SSet s (a, b, c, d, e, f) where-    act s (a, b, c, d, e, f) = (act s a, act s b, act s c, act s d, act s e, act s f)--instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e, SSet s f, SSet s h) => SSet s (a, b, c, d, e, f, h) where-    act s (a, b, c, d, e, f, h) = (act s a, act s b, act s c, act s d, act s e, act s f, act s h)--instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e, SSet s f, SSet s h, SSet s i) => SSet s (a, b, c, d, e, f, h, i) where-    act s (a, b, c, d, e, f, h, i) = (act s a, act s b, act s c, act s d, act s e, act s f, act s h, act s i)--instance SSet s a => SSet s [a] where-    act s = map (act s)--instance SSet s a => SSet s (NonEmpty a) where-    act s as = NE.map (act s) as--instance (SSet s a, Ord a) => SSet s (Set a) where-    act s as = Set.map (act s) as---- |--- Any @'SSet'@ wrapped in a functor is a valid @'SSet'@.-fact :: (Functor f, SSet s a) => s -> f a -> f a-fact s = fmap (act s)--instance SSet s a => SSet s (Identity a) where-    act = fact--instance SSet s a => SSet (Identity s) a where-    act (Identity f) a = f `act` a--instance SSet s a => SSet s (Maybe a) where-    act = fact--instance SSet s b => SSet s (Either a b) where-    act = fact--instance SSet s a => SSet s (Down a) where-    act s (Down a) =  Down (act s a)--instance SSet s a => SSet s (IO a) where-    act = fact--instance SSet s b => SSet s (a -> b) where-    act = fact--instance SSet (Endo a) a where-    act = appEndo---- |--- 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__ < 804-    S s `mappend` S s' = S $ s `mappend` s'-#endif--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-    act (Sum n) s = s `mappend` act (Sum (n - 1)) s--instance Group g => SSet (Sum Integer) g where-    act (Sum n) g | n < 0      = invert g `mappend` act (Sum (n + 1)) g-                  | n > 0      = g `mappend` act (Sum (n - 1)) g-                  | otherwise  = mempty--instance SSet s a => SSet s (Const a b) where-    act s (Const a) = Const $ s `act` a--instance (Functor f, Functor h, SSet s a) => SSet s (Functor.Product f h a) where-    act = fact--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

@@ -8,8 +8,6 @@ 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@@ -23,6 +21,4 @@         [ 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         ]

@@ -1,88 +0,0 @@-{-# 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)

@@ -1,89 +0,0 @@-{-# 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)