Monoid.hs

{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Precursor.Algebra.Monoid
  ( -- * 'Monoid' typeclass
    Monoid
  , mempty
  , mappend
  , Dual(..)
  , Endo(..)
    -- * 'Semiring' wrappers
  , Sum(..)
  , Product(..)
  -- * A better monoid for Maybe
  , Option(..)
  , option
  ) where

import           Precursor.Control.Applicative
import           Data.Coerce
import           Data.Semigroup hiding (Product (..), Sum (..))
import           Precursor.Control.Functor
import           GHC.Generics
import           Precursor.Control.Monad
import           Precursor.Numeric.Num
import           Prelude        (Bounded, Eq, Ord)
import           Precursor.Algebra.Semiring
import           Precursor.Text.Show

-- | Monoid under addition.
newtype Sum a = Sum { getSum :: a }
        deriving (Eq, Ord, Bounded, Generic, Generic1, Num)

instance TextShow a => TextShow (Sum a) where showbPrec = gShowPrec

instance Semiring a => Semigroup (Sum a) where
  (<>) =
    (coerce :: (a -> a -> a) -> (Sum a -> Sum a -> Sum a)) (+)

instance Semiring a => Monoid (Sum a) where
  mappend = (<>)
  mempty = Sum zero

instance Functor Sum where
    fmap     = coerce

instance Applicative Sum where
    pure     = Sum
    (<*>)    = coerce

instance Monad Sum where
    m >>= k  = k (getSum m)

-- | Monoid under multiplication.
newtype Product a = Product { getProduct :: a }
        deriving (Eq, Ord, Bounded, Generic, Generic1, Num)

instance TextShow a => TextShow (Product a) where showbPrec = gShowPrec

instance Semiring a => Semigroup (Product a) where
  (<>) =
    (coerce :: (a -> a -> a) -> (Product a -> Product a -> Product a)) (*)

instance Semiring a => Monoid (Product a) where
        mempty = Product one
        mappend = (<>)

instance Functor Product where
    fmap     = coerce

instance Applicative Product where
    pure     = Product
    (<*>)    = coerce

instance Monad Product where
    m >>= k  = k (getProduct m)