{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts, TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MonoLocalBinds #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module Data.Semigroup.Monad
( Action(..)
, Mon(..)
) where
import Control.Monad (liftM, liftM2)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
import Data.Monoid (Monoid(..))
#endif
import Data.Semigroup (Semigroup(..))
import Data.Semigroup.Reducer (Reducer(..))
newtype Action f = Action { getAction :: f () }
instance Monad f => Semigroup (Action f) where
Action a <> Action b = Action (a >> b)
instance Monad f => Monoid (Action f) where
mempty = Action (return ())
Action a `mappend` Action b = Action (a >> b)
instance Monad f => Reducer (f a) (Action f) where
unit a = Action (a >> return ())
a `cons` Action b = Action (a >> b)
Action a `snoc` b = Action (a >> b >> return ())
snocAction :: Reducer (f ()) (Action f) => Action f -> f () -> Action f
snocAction a = (<>) a . Action
{-# RULES "unitAction" unit = Action #-}
{-# RULES "snocAction" snoc = snocAction #-}
newtype Mon f m = Mon { getMon :: f m }
deriving (Functor,Applicative,Monad)
instance (Monad f, Semigroup m) => Semigroup (Mon f m) where
(<>) = liftM2 (<>)
instance (Monad f, Monoid m) => Monoid (Mon f m) where
mempty = return mempty
mappend = liftM2 mappend
instance (Monad f, Reducer c m) => Reducer (f c) (Mon f m) where
unit = liftM unit . Mon