singletons-base-3.0: src/Data/Monoid/Singletons.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Monoid.Singletons
-- Copyright : (C) 2018 Ryan Scott
-- License : BSD-style (see LICENSE)
-- Maintainer : Ryan Scott
-- Stability : experimental
-- Portability : non-portable
--
-- Defines the promoted version of 'Monoid', 'PMonoid', and the
-- singleton version, 'SMonoid'.
--
----------------------------------------------------------------------------
module Data.Monoid.Singletons (
PMonoid(..), SMonoid(..),
Sing, SDual(..), SAll(..), SAny(..),
SSum(..), SProduct(..), SFirst(..), SLast(..),
GetDual, GetAll, GetAny, GetSum, GetProduct, GetFirst, GetLast,
sGetDual, sGetAll, sGetAny, sGetSum, sGetProduct, sGetFirst, sGetLast,
-- ** Defunctionalization symbols
MemptySym0,
MappendSym0, MappendSym1, MappendSym2,
MconcatSym0, MconcatSym1,
DualSym0, DualSym1, GetDualSym0, GetDualSym1,
AllSym0, AllSym1, GetAllSym0, GetAllSym1,
AnySym0, AnySym1, GetAnySym0, GetAnySym1,
SumSym0, SumSym1, GetSumSym0, GetSumSym1,
ProductSym0, ProductSym1, GetProductSym0, GetProductSym1,
FirstSym0, FirstSym1, GetFirstSym0, GetFirstSym1,
LastSym0, LastSym1, GetLastSym0, GetLastSym1
) where
import Control.Monad.Singletons.Internal
import Data.Eq.Singletons
import Data.Monoid (First(..), Last(..))
import Data.Ord (Down(..))
import Data.Ord.Singletons
import Data.Semigroup hiding (First(..), Last(..))
import Data.Semigroup.Singletons.Internal hiding
(SFirst, SLast,
FirstSym0, FirstSym1, FirstSym0KindInference,
LastSym0, LastSym1, LastSym0KindInference,
GetFirst, sGetFirst, GetFirstSym0, GetFirstSym1, GetFirstSym0KindInference,
GetLast, sGetLast, GetLastSym0, GetLastSym1, GetLastSym0KindInference)
import Data.Singletons.Base.Instances
import Data.Singletons.Base.Util
import Data.Singletons.TH
import GHC.Base.Singletons
import GHC.Num.Singletons
import GHC.TypeLits (Symbol)
import Text.Show.Singletons
$(singletonsOnly [d|
-- -| The class of monoids (types with an associative binary operation that
-- has an identity). Instances should satisfy the following laws:
--
-- * @x '<>' 'mempty' = x@
--
-- * @'mempty' '<>' x = x@
--
-- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law)
--
-- * @'mconcat' = 'foldr' '(<>)' 'mempty'@
--
-- The method names refer to the monoid of lists under concatenation,
-- but there are many other instances.
--
-- Some types can be viewed as a monoid in more than one way,
-- e.g. both addition and multiplication on numbers.
-- In such cases we often define @newtype@s and make those instances
-- of 'Monoid', e.g. 'Sum' and 'Product'.
class Semigroup a => Monoid a where
-- -| Identity of 'mappend'
mempty :: a
-- -| An associative operation
--
-- __NOTE__: This method is redundant and has the default
-- implementation @'mappend' = '(<>)'@.
mappend :: a -> a -> a
mappend = (<>)
-- -| Fold a list using the monoid.
--
-- For most types, the default definition for 'mconcat' will be
-- used, but the function is included in the class definition so
-- that an optimized version can be provided for specific types.
mconcat :: [a] -> a
mconcat = foldr mappend mempty
instance Monoid [a] where
mempty = []
-- mconcat xss = [x | xs <- xss, x <- xs]
instance Monoid b => Monoid (a -> b) where
mempty _ = mempty
instance Monoid () where
-- Should it be strict?
mempty = ()
mconcat _ = ()
instance (Monoid a, Monoid b) => Monoid (a,b) where
mempty = (mempty, mempty)
instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
mempty = (mempty, mempty, mempty)
instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
mempty = (mempty, mempty, mempty, mempty)
instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
Monoid (a,b,c,d,e) where
mempty = (mempty, mempty, mempty, mempty, mempty)
-- lexicographical ordering
instance Monoid Ordering where
mempty = EQ
-- -| Lift a semigroup into 'Maybe' forming a 'Monoid' according to
-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
-- turned into a monoid simply by adjoining an element @e@ not in @S@
-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\"
instance Semigroup a => Monoid (Maybe a) where
mempty = Nothing
instance Monoid Symbol where
mempty = ""
|])
$(genSingletons monoidBasicTypes)
$(showSingInstances monoidBasicTypes)
$(singEqInstances monoidBasicTypes)
$(singDecideInstances monoidBasicTypes)
$(singOrdInstances monoidBasicTypes)
$(singShowInstances monoidBasicTypes)
$(singletonsOnly [d|
instance Monoid a => Monoid (Dual a) where
mempty = Dual mempty
instance Monoid All where
mempty = All True
instance Monoid Any where
mempty = Any False
instance Num a => Monoid (Sum a) where
mempty = Sum 0
instance Num a => Monoid (Product a) where
mempty = Product 1
-- deriving newtype instance Monoid a => Monoid (Down a)
instance Monoid a => Monoid (Down a) where
mempty = Down mempty
-- deriving newtype instance Applicative First
instance Applicative First where
pure = First . pure
First f <*> First x = First (f <*> x)
deriving instance Functor First
-- deriving newtype instance Monad First
instance Monad First where
First a >>= k = First (a >>= \x -> case k x of First y -> y)
instance Semigroup (First a) where
First Nothing <> b = b
a@(First Just{}) <> _ = a
instance Monoid (First a) where
mempty = First Nothing
-- deriving newtype instance Applicative Last
instance Applicative Last where
pure = Last . pure
Last f <*> Last x = Last (f <*> x)
deriving instance Functor Last
-- deriving newtype instance Monad Last
instance Monad Last where
Last a >>= k = Last (a >>= \x -> case k x of Last y -> y)
instance Semigroup (Last a) where
a <> Last Nothing = a
_ <> b@(Last Just {}) = b
instance Monoid (Last a) where
mempty = Last Nothing
|])