SemiRing with better type inference

algebra2.hs

{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Algebra where

import           GHC.Exts (coerce)
import           Prelude  hiding (Monoid)

-- $setup
-- >>> :set -XAllowAmbiguousTypes
-- >>> :set -XDataKinds
-- >>> :set -XFlexibleContexts
-- >>> :set -XFlexibleInstances
-- >>> :set -XGeneralizedNewtypeDeriving
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XScopedTypeVariables
-- >>> :set -XTypeApplications
-- >>> :set -XTypeFamilies
-- >>> :set -XUndecidableInstances

newtype Sum a = Sum { getSum :: a }
  deriving (Show, Num)

newtype Product a = Product { getProduct :: a }
  deriving (Show, Num)

-- | Kind-of a singleton class for binary operations, which
-- associates an arbitrary proxy with some value-level operation.
class Magma a where
  op :: a -> a -> a

instance Num a => Magma (Sum a) where
  op (Sum a) (Sum b) = Sum (a + b)

instance Num a => Magma (Product a) where
  op (Product a) (Product b) = Product (a * b)

-- |
-- >>> getSum example1
-- 9
-- >>> getProduct example1
-- 24
example1 :: (Magma a, Num a) => a
example1 = 2 `op` 3 `op` 4

-- | Blah laws
class Magma a => SemiGroup a

instance Num a => SemiGroup (Sum a)

instance Num a => SemiGroup (Product a)

class SemiGroup a => Monoid a where
  neutral :: a

instance Num a => Monoid (Sum a) where
  neutral = Sum 0

instance Num a => Monoid (Product a) where
  neutral = Product 1

class Monoid a => Group a where
  inverse :: a -> a

instance Num a => Group (Sum a) where
  inverse (Sum a) = Sum (negate a)

-- | Blah laws
class (Group (Sum a), Monoid (Product a)) => SemiRing a

instance Num a => SemiRing a

zero :: forall a. SemiRing a => a
zero = coerce (neutral @(Sum a))

one :: forall a. SemiRing a => a
one = coerce (neutral @(Product a))

plus :: forall a. SemiRing a => a -> a -> a
plus = coerce (op @(Sum a))

minus :: SemiRing a => a -> a -> a
minus x y = coerce (op (Sum x) (inverse (Sum y)))

multiply :: forall a. SemiRing a => a -> a -> a
multiply = coerce (op @(Product a))

-- |
-- >>> example2 @Int
-- 25
example2 :: (SemiRing a, Num a) => a
example2 = ((o + ((five * five) - o)) - (five * z)) + z
  where
    z = zero
    o = one
    five = o + o + o + o + o
    (+) = plus
    (-) = minus
    (*) = multiply