Semigroup.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK hide #-}

-- | This module provides a linear version of 'Semigroup'.
module Data.Monoid.Linear.Internal.Semigroup
  ( -- * Semigroup
    Semigroup (..),

    -- * Endo
    Endo (..),
    appEndo,

    -- * NonLinear newtype
    NonLinear (..),

    -- * Data.Semigroup reexports
    All (..),
    Any (..),
    First (..),
    Last (..),
    Dual (..),
    Sum (..),
    Product (..),
  )
where

import qualified Data.Functor.Compose as Functor
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import qualified Data.Functor.Product as Functor
import qualified Data.Monoid as Monoid
import Data.Ord (Down (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup
  ( All (..),
    Any (..),
    Dual (..),
    First (..),
    Last (..),
    Product (..),
    Sum (..),
  )
import qualified Data.Semigroup as Prelude
import qualified Data.Tuple.Linear.Compat as Tuple
import Data.Unrestricted.Linear.Internal.Consumable (Consumable, lseq)
import qualified Data.Unrestricted.Linear.Internal.Ur as Ur
import Data.Void (Void)
import GHC.Tuple
import GHC.Types hiding (Any)
import Prelude.Linear.Internal
import Prelude (Either (..), Maybe (..))

-- | A linear semigroup @a@ is a type with an associative binary operation @<>@
-- that linearly consumes two @a@s.
--
-- Laws (same as 'Data.Semigroup.Semigroup'):
--   * ∀ x ∈ G, y ∈ G, z ∈ G, x <> (y <> z) = (x <> y) <> z
class Semigroup a where
  (<>) :: a %1 -> a %1 -> a
  infixr 6 <> -- same fixity as base.<>

-- | An @'Endo' a@ is just a linear function of type @a %1-> a@.
-- This has a classic monoid definition with 'id' and '(.)'.
newtype Endo a = Endo (a %1 -> a)
  deriving (Prelude.Semigroup) via NonLinear (Endo a)

-- TODO: have this as a newtype deconstructor once the right type can be
-- correctly inferred

-- | A linear application of an 'Endo'.
appEndo :: Endo a %1 -> a %1 -> a
appEndo (Endo f) = f

-- | @DerivingVia@ combinator for 'Prelude.Semigroup' (resp. 'Prelude.Monoid')
-- given linear 'Semigroup' (resp. 'Monoid').
--
-- > newtype Endo a = Endo (a %1-> a)
-- >   deriving (Prelude.Semigroup) via NonLinear (Endo a)
newtype NonLinear a = NonLinear a

---------------
-- Instances --
---------------

instance (Semigroup a) => Prelude.Semigroup (NonLinear a) where
  NonLinear a <> NonLinear b = NonLinear (a <> b)

-- Instances below are listed in the same order as in https://hackage.haskell.org/package/base-4.16.0.0/docs/Data-Semigroup.html

instance Semigroup All where
  All False <> All False = All False
  All False <> All True = All False
  All True <> All False = All False
  All True <> All True = All True

instance Semigroup Any where
  Any False <> Any False = Any False
  Any False <> Any True = Any True
  Any True <> Any False = Any True
  Any True <> Any True = Any True

instance Semigroup Void where
  (<>) = \case {}

instance Semigroup Ordering where
  LT <> LT = LT
  LT <> GT = LT
  LT <> EQ = LT
  EQ <> y = y
  GT <> LT = GT
  GT <> GT = GT
  GT <> EQ = GT

instance Semigroup () where
  () <> () = ()

instance (Semigroup a) => Semigroup (Identity a) where
  Identity x <> Identity y = Identity (x <> y)

instance (Consumable a) => Semigroup (Monoid.First a) where
  (Monoid.First Nothing) <> y = y
  x <> (Monoid.First y) =
    case y of
      Nothing -> x
      Just y' -> y' `lseq` x

instance (Consumable a) => Semigroup (Monoid.Last a) where
  x <> (Monoid.Last Nothing) = x
  (Monoid.Last x) <> y =
    case x of
      Nothing -> y
      Just x' -> x' `lseq` y

instance (Semigroup a) => Semigroup (Down a) where
  (Down x) <> (Down y) = Down (x <> y)

instance (Consumable a) => Semigroup (First a) where
  x <> (First y) = y `lseq` x

instance (Consumable a) => Semigroup (Last a) where
  (Last x) <> y = x `lseq` y

-- Cannot add instance Ord a => Semigroup (Max a); would require (NonLinear.Ord a, Consumable a)
-- Cannot add instance Ord a => Semigroup (Min a); would require (NonLinear.Ord a, Consumable a)

instance (Semigroup a) => Semigroup (Dual a) where
  Dual x <> Dual y = Dual (y <> x)

instance Semigroup (Endo a) where
  Endo f <> Endo g = Endo (f . g)

-- See Data.Num.Linear for instance ... => Semigroup (Product a)
-- See Data.Num.Linear for instance ... => Semigroup (Sum a)
-- See System.IO.Linear for instance ... => Semigroup (IO a)
-- See System.IO.Resource.Internal for instance ... => Semigroup (RIO a)
-- See Data.List.Linear for instance ... => Semigroup (NonEmpty a)

instance (Semigroup a) => Semigroup (Maybe a) where
  x <> Nothing = x
  Nothing <> y = y
  Just x <> Just y = Just (x <> y)

instance (Semigroup a) => Semigroup (Solo a) where
  x <> y = Tuple.mkSolo (Tuple.unSolo x <> Tuple.unSolo y)

-- See Data.List.Linear for instance ... => Semigroup [a]

instance (Consumable a, Consumable b) => Semigroup (Either a b) where
  Left x <> y = x `lseq` y
  x <> y =
    case y of
      Left y' -> y' `lseq` x
      Right y' -> y' `lseq` x

-- Cannot add instance Semigroup a => Semigroup (Op a b); would require Dupable b

instance Semigroup (Proxy a) where
  Proxy <> Proxy = Proxy

-- Cannot add instance Semigroup a => Semigroup (ST s a); I think that it would require a linear ST monad
-- Cannot add instance Semigroup b => Semigroup (a -> b); would require Dupable a

instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
  (x1, x2) <> (y1, y2) = (x1 <> y1, x2 <> y2)

instance (Semigroup a) => Semigroup (Const a b) where
  Const x <> Const y = Const (x <> y)

-- See Data.Functor.Linear.Applicative for instance ... => Semigroup (Ap f a)
-- Cannot add instance Alternative f => Semigroup (Alt f a); we don't have a linear Alternative

instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
  (x1, x2, x3) <> (y1, y2, y3) = (x1 <> y1, x2 <> y2, x3 <> y3)

instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Functor.Product f g a) where
  Functor.Pair x1 x2 <> Functor.Pair y1 y2 = Functor.Pair (x1 <> y1) (x2 <> y2)

instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) => Semigroup (a, b, c, d) where
  (x1, x2, x3, x4) <> (y1, y2, y3, y4) = (x1 <> y1, x2 <> y2, x3 <> y3, x4 <> y4)

instance (Semigroup (f (g a))) => Semigroup (Functor.Compose f g a) where
  Functor.Compose x <> Functor.Compose y = Functor.Compose (x <> y)

instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) => Semigroup (a, b, c, d, e) where
  (x1, x2, x3, x4, x5) <> (y1, y2, y3, y4, y5) = (x1 <> y1, x2 <> y2, x3 <> y3, x4 <> y4, x5 <> y5)

-- | Useful to treat /unrestricted/ semigroups as linear ones.
instance (Prelude.Semigroup a) => Semigroup (Ur.Ur a) where
  (<>) = Ur.lift2 (Prelude.<>)
  {-# INLINE (<>) #-}