{-# LANGUAGE CPP                  #-}
#if MIN_VERSION_base(4,6,0)
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
#endif

-- below are safe orphan instances
{-# OPTIONS_GHC -fno-warn-orphans #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Semiring.Generic
-- Copyright   :  (C) 2018 chessai
-- License     :  MIT (see the file LICENSE)
--
-- Maintainer  :  chessai <chessai1996@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- This module provides generic deriving tools for semirings and rings for
-- product-like structures.
--
----------------------------------------------------------------------------

module Data.Semiring.Generic
  (
#if MIN_VERSION_base(4,6,0)
    GSemiring(..)
  , gzero
  , gone
  , gplus
  , gtimes
  , gfromNatural
  , GRing(..)
  , gnegate
  , GenericSemiring(..)
#endif
  ) where

#if MIN_VERSION_base(4,6,0)
import           Data.Semiring
import           GHC.Generics
import           Numeric.Natural (Natural)

import Prelude hiding (Num(..))

-- | An Identity-style wrapper with a 'Generic' interface
--   to be used with '-XDerivingVia'.
newtype GenericSemiring a = GenericSemiring a

instance (Generic a, GSemiring (Rep a)) => Semiring (GenericSemiring a) where
  zero :: GenericSemiring a
zero = forall a. a -> GenericSemiring a
GenericSemiring forall a. (Generic a, GSemiring (Rep a)) => a
gzero
  one :: GenericSemiring a
one = forall a. a -> GenericSemiring a
GenericSemiring forall a. (Generic a, GSemiring (Rep a)) => a
gone
  plus :: GenericSemiring a -> GenericSemiring a -> GenericSemiring a
plus (GenericSemiring a
x) (GenericSemiring a
y) = forall a. a -> GenericSemiring a
GenericSemiring (forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus a
x a
y)
  times :: GenericSemiring a -> GenericSemiring a -> GenericSemiring a
times (GenericSemiring a
x) (GenericSemiring a
y) = forall a. a -> GenericSemiring a
GenericSemiring (forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes a
x a
y)
  fromNatural :: Natural -> GenericSemiring a
fromNatural Natural
x = forall a. a -> GenericSemiring a
GenericSemiring (forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural Natural
x)

instance (Semiring a, Semiring b) => Semiring (a,b) where
  zero :: (a, b)
zero = forall a. (Generic a, GSemiring (Rep a)) => a
gzero; one :: (a, b)
one = forall a. (Generic a, GSemiring (Rep a)) => a
gone; plus :: (a, b) -> (a, b) -> (a, b)
plus = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus; times :: (a, b) -> (a, b) -> (a, b)
times = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes; fromNatural :: Natural -> (a, b)
fromNatural = forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural;

instance (Semiring a, Semiring b, Semiring c) => Semiring (a,b,c) where
  zero :: (a, b, c)
zero = forall a. (Generic a, GSemiring (Rep a)) => a
gzero; one :: (a, b, c)
one = forall a. (Generic a, GSemiring (Rep a)) => a
gone; plus :: (a, b, c) -> (a, b, c) -> (a, b, c)
plus = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus; times :: (a, b, c) -> (a, b, c) -> (a, b, c)
times = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes; fromNatural :: Natural -> (a, b, c)
fromNatural = forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural;

instance (Semiring a, Semiring b, Semiring c, Semiring d) => Semiring (a,b,c,d) where
  zero :: (a, b, c, d)
zero = forall a. (Generic a, GSemiring (Rep a)) => a
gzero; one :: (a, b, c, d)
one = forall a. (Generic a, GSemiring (Rep a)) => a
gone; plus :: (a, b, c, d) -> (a, b, c, d) -> (a, b, c, d)
plus = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus; times :: (a, b, c, d) -> (a, b, c, d) -> (a, b, c, d)
times = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes; fromNatural :: Natural -> (a, b, c, d)
fromNatural = forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural;

instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e) => Semiring (a,b,c,d,e) where
  zero :: (a, b, c, d, e)
zero = forall a. (Generic a, GSemiring (Rep a)) => a
gzero; one :: (a, b, c, d, e)
one = forall a. (Generic a, GSemiring (Rep a)) => a
gone; plus :: (a, b, c, d, e) -> (a, b, c, d, e) -> (a, b, c, d, e)
plus = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus; times :: (a, b, c, d, e) -> (a, b, c, d, e) -> (a, b, c, d, e)
times = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes; fromNatural :: Natural -> (a, b, c, d, e)
fromNatural = forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural;

instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e, Semiring f) => Semiring (a,b,c,d,e,f) where
  zero :: (a, b, c, d, e, f)
zero = forall a. (Generic a, GSemiring (Rep a)) => a
gzero; one :: (a, b, c, d, e, f)
one = forall a. (Generic a, GSemiring (Rep a)) => a
gone; plus :: (a, b, c, d, e, f) -> (a, b, c, d, e, f) -> (a, b, c, d, e, f)
plus = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus; times :: (a, b, c, d, e, f) -> (a, b, c, d, e, f) -> (a, b, c, d, e, f)
times = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes; fromNatural :: Natural -> (a, b, c, d, e, f)
fromNatural = forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural;

instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e, Semiring f, Semiring g) => Semiring (a,b,c,d,e,f,g) where
  zero :: (a, b, c, d, e, f, g)
zero = forall a. (Generic a, GSemiring (Rep a)) => a
gzero; one :: (a, b, c, d, e, f, g)
one = forall a. (Generic a, GSemiring (Rep a)) => a
gone; plus :: (a, b, c, d, e, f, g)
-> (a, b, c, d, e, f, g) -> (a, b, c, d, e, f, g)
plus = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus; times :: (a, b, c, d, e, f, g)
-> (a, b, c, d, e, f, g) -> (a, b, c, d, e, f, g)
times = forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes; fromNatural :: Natural -> (a, b, c, d, e, f, g)
fromNatural = forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural;

instance (Ring a, Ring b) => Ring (a,b) where
  negate :: (a, b) -> (a, b)
negate = forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate

instance (Ring a, Ring b, Ring c) => Ring (a,b,c) where
  negate :: (a, b, c) -> (a, b, c)
negate = forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate

instance (Ring a, Ring b, Ring c, Ring d) => Ring (a,b,c,d) where
  negate :: (a, b, c, d) -> (a, b, c, d)
negate = forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate

instance (Ring a, Ring b, Ring c, Ring d, Ring e) => Ring (a,b,c,d,e) where
  negate :: (a, b, c, d, e) -> (a, b, c, d, e)
negate = forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate

instance (Ring a, Ring b, Ring c, Ring d, Ring e, Ring f) => Ring (a,b,c,d,e,f) where
  negate :: (a, b, c, d, e, f) -> (a, b, c, d, e, f)
negate = forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate

instance (Ring a, Ring b, Ring c, Ring d, Ring e, Ring f, Ring g) => Ring (a,b,c,d,e,f,g) where
  negate :: (a, b, c, d, e, f, g) -> (a, b, c, d, e, f, g)
negate = forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate

{--------------------------------------------------------------------
  Generics
--------------------------------------------------------------------}

-- | Generic 'Semiring' class, used to implement 'plus', 'times', 'zero',
--   and 'one' for product-like types implementing 'Generic'.
class GSemiring f where
#if __GLASGOW_HASKELL__ >= 708
  {-# MINIMAL gplus', gzero', gtimes', gone', gfromNatural' #-}
#endif
  gzero'  :: f a
  gone'   :: f a
  gplus'  :: f a -> f a -> f a
  gtimes' :: f a -> f a -> f a
  gfromNatural' :: Natural -> f a

-- | Generic 'Ring' class, used to implement 'negate' for product-like
--   types implementing 'Generic'.
class GRing f where
#if __GLASGOW_HASKELL__ >= 708
  {-# MINIMAL gnegate' #-}
#endif
  gnegate' :: f a -> f a

-- | Generically generate a 'Semiring' 'zero' for any product-like type
-- implementing 'Generic'.
--
-- It is only defined for product types.
--
-- @
-- 'gplus' 'gzero' a = a = 'gplus' a 'gzero'
-- @
gzero :: (Generic a, GSemiring (Rep a)) => a
gzero :: forall a. (Generic a, GSemiring (Rep a)) => a
gzero = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a. GSemiring f => f a
gzero'

-- | Generically generate a 'Semiring' 'one' for any product-like type
-- implementing 'Generic'.
--
-- It is only defined for product types.
--
-- @
-- 'gtimes' 'gone' a = a = 'gtimes' a 'gone'
-- @
gone :: (Generic a, GSemiring (Rep a)) => a
gone :: forall a. (Generic a, GSemiring (Rep a)) => a
gone  = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a. GSemiring f => f a
gone'

-- | Generically generate a 'Semiring' 'plus' operation for any type
-- implementing 'Generic'. It is only defined for product types.
--
-- @
-- 'gplus' a b = 'gplus' b a
-- @
gplus :: (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus :: forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gplus a
x a
y = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
from a
x forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
`gplus'` forall a x. Generic a => a -> Rep a x
from a
y

-- | Generically generate a 'Semiring' 'times' operation for any type
-- implementing 'Generic'. It is only defined for product types.
--
-- @
-- 'gtimes' a ('gtimes' b c) = 'gtimes' ('gtimes' a b) c
-- 'gtimes' a 'gzero' = 'gzero' = 'gtimes' 'gzero' a
-- @
gtimes :: (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes :: forall a. (Generic a, GSemiring (Rep a)) => a -> a -> a
gtimes a
x a
y = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
from a
x forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
`gtimes'` forall a x. Generic a => a -> Rep a x
from a
y

-- | Generically generate a 'Semiring' 'fromNatural' for any product-like type
-- implementing 'Generic'.
--
-- It is only defined for product types.
gfromNatural :: (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural :: forall a. (Generic a, GSemiring (Rep a)) => Natural -> a
gfromNatural = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. GSemiring f => Natural -> f a
gfromNatural'

-- | Generically generate a 'Ring' 'negate' operation for any type
-- implementing 'Generic'. It is only defined for product types.
--
-- @
-- 'gplus' a ('gnegate' a) = 'zero'
-- @
gnegate :: (Generic a, GRing (Rep a)) => a -> a
gnegate :: forall a. (Generic a, GRing (Rep a)) => a -> a
gnegate a
x = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. GRing f => f a -> f a
gnegate' forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
from a
x

instance GSemiring U1 where
  gzero' :: forall a. U1 a
gzero' = forall k (p :: k). U1 p
U1
  gone' :: forall a. U1 a
gone'  = forall k (p :: k). U1 p
U1
  gplus' :: forall a. U1 a -> U1 a -> U1 a
gplus'  U1 a
_ U1 a
_ = forall k (p :: k). U1 p
U1
  gtimes' :: forall a. U1 a -> U1 a -> U1 a
gtimes' U1 a
_ U1 a
_ = forall k (p :: k). U1 p
U1
  gfromNatural' :: forall a. Natural -> U1 a
gfromNatural' Natural
_ = forall k (p :: k). U1 p
U1

instance GRing U1 where
  gnegate' :: forall a. U1 a -> U1 a
gnegate' U1 a
_ = forall k (p :: k). U1 p
U1

instance (GSemiring a, GSemiring b) => GSemiring (a :*: b) where
  gzero' :: forall a. (:*:) a b a
gzero' = forall (f :: * -> *) a. GSemiring f => f a
gzero' forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. GSemiring f => f a
gzero'
  gone' :: forall a. (:*:) a b a
gone'  = forall (f :: * -> *) a. GSemiring f => f a
gone'  forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. GSemiring f => f a
gone'
  gplus' :: forall a. (:*:) a b a -> (:*:) a b a -> (:*:) a b a
gplus'  (a a
a :*: b a
b) (a a
c :*: b a
d) = forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
gplus'  a a
a a a
c forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
gplus' b a
b b a
d
  gtimes' :: forall a. (:*:) a b a -> (:*:) a b a -> (:*:) a b a
gtimes' (a a
a :*: b a
b) (a a
c :*: b a
d) = forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
gtimes' a a
a a a
c forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
gtimes' b a
b b a
d
  gfromNatural' :: forall a. Natural -> (:*:) a b a
gfromNatural' Natural
n = forall (f :: * -> *) a. GSemiring f => Natural -> f a
gfromNatural' Natural
n forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. GSemiring f => Natural -> f a
gfromNatural' Natural
n

instance (GRing a, GRing b) => GRing (a :*: b) where
  gnegate' :: forall a. (:*:) a b a -> (:*:) a b a
gnegate' (a a
a :*: b a
b) = forall (f :: * -> *) a. GRing f => f a -> f a
gnegate' a a
a forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. GRing f => f a -> f a
gnegate' b a
b

instance (GSemiring a) => GSemiring (M1 i c a) where
  gzero' :: forall a. M1 i c a a
gzero' = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a. GSemiring f => f a
gzero'
  gone' :: forall a. M1 i c a a
gone'  = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a. GSemiring f => f a
gone'
  gplus' :: forall a. M1 i c a a -> M1 i c a a -> M1 i c a a
gplus'  (M1 a a
x) (M1 a a
y) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
gplus'  a a
x a a
y
  gtimes' :: forall a. M1 i c a a -> M1 i c a a -> M1 i c a a
gtimes' (M1 a a
x) (M1 a a
y) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. GSemiring f => f a -> f a -> f a
gtimes' a a
x a a
y
  gfromNatural' :: forall a. Natural -> M1 i c a a
gfromNatural' = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. GSemiring f => Natural -> f a
gfromNatural'

instance (GRing a) => GRing (M1 i c a) where
  gnegate' :: forall a. M1 i c a a -> M1 i c a a
gnegate' (M1 a a
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. GRing f => f a -> f a
gnegate' a a
x

instance (Semiring a) => GSemiring (K1 i a) where
  gzero' :: forall a. K1 i a a
gzero' = forall k i c (p :: k). c -> K1 i c p
K1 forall a. Semiring a => a
zero
  gone' :: forall a. K1 i a a
gone'  = forall k i c (p :: k). c -> K1 i c p
K1 forall a. Semiring a => a
one
  gplus' :: forall a. K1 i a a -> K1 i a a -> K1 i a a
gplus'  (K1 a
x) (K1 a
y) = forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall a. Semiring a => a -> a -> a
plus  a
x a
y
  gtimes' :: forall a. K1 i a a -> K1 i a a -> K1 i a a
gtimes' (K1 a
x) (K1 a
y) = forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall a. Semiring a => a -> a -> a
times a
x a
y
  gfromNatural' :: forall a. Natural -> K1 i a a
gfromNatural' = forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semiring a => Natural -> a
fromNatural

instance (Ring a) => GRing (K1 i a) where
  gnegate' :: forall a. K1 i a a -> K1 i a a
gnegate' (K1 a
x) = forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall a. Ring a => a -> a
negate a
x
#endif