{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wall #-}

#include "ConCat/Ops.inc"

-- | Commutative monoid intended to be used with a multiplicative monoid

module ConCat.Additive where

import Prelude hiding (zipWith)
import Data.Monoid (Monoid(..), Sum(..), Product(..))
import Data.Semigroup (Semigroup(..))
import Data.Complex hiding (magnitude)
import Data.Ratio
import Data.Int
import Data.Word
import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CDouble)
import GHC.Generics (U1(..),Par1(..),(:*:)(..),(:.:)(..))
import GHC.TypeLits (KnownNat)

import Data.Key(Zip(..))
import Data.Pointed
import Data.Functor.Rep (Representable(..))
import Data.Vector.Sized (Vector)
import Data.Finite.Internal

import ConCat.Misc
import ConCat.Rep (HasRep(abst),inAbst,inAbst2)
import qualified ConCat.Rep
import ConCat.Orphans ()

-- | Commutative monoid intended to be used with a multiplicative monoid
class Additive a where
  zero  :: a
  infixl 6 ^+^
  (^+^) :: a -> a -> a
  default zero :: (Pointed h, Additive b, a ~ h b) => a
  zero = b -> h b
forall (h :: * -> *) a. Pointed h => a -> h a
pointNI b
forall a. Additive a => a
zero
  default (^+^) :: (Zip h, Additive b, a ~ h b) => Binop a
  (^+^) = (b -> b -> b) -> h b -> h b -> h b
forall (h :: * -> *) a b c.
Zip h =>
(a -> b -> c) -> h a -> h b -> h c
zipWithNI b -> b -> b
forall a. Additive a => Binop a
(^+^)
  {-# INLINE zero #-}
  {-# INLINE (^+^) #-}

-- These definitions and the corresponding Catify rewrites in AltCat prevent the point and zipWith methods from getting inlined too soon.
-- See 2018-04-09 notes.
pointNI :: Pointed h => a -> h a
pointNI :: forall (h :: * -> *) a. Pointed h => a -> h a
pointNI = a -> h a
forall a. a -> h a
forall (p :: * -> *) a. Pointed p => a -> p a
point
{-# INLINE [0] pointNI #-}

zipWithNI :: Zip h => (a -> b -> c) -> h a -> h b -> h c
zipWithNI :: forall (h :: * -> *) a b c.
Zip h =>
(a -> b -> c) -> h a -> h b -> h c
zipWithNI = (a -> b -> c) -> h a -> h b -> h c
forall a b c. (a -> b -> c) -> h a -> h b -> h c
forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> f a -> f b -> f c
zipWith
{-# INLINE [0] zipWithNI #-}

instance Additive () where
  zero :: ()
zero = ()
  () ^+^ :: () -> () -> ()
^+^ () = ()

#define ScalarType(t) \
  instance Additive (t) where { zero = 0 ; (^+^) = (+);\
  {-# INLINE zero #-}; \
  {-# INLINE (^+^) #-} }

ScalarType(Int)
ScalarType(Int16)
ScalarType(Int32)
ScalarType(Int64)
ScalarType(Int8)
ScalarType(Integer)
ScalarType(Float)
ScalarType(Double)
ScalarType(CSChar)
ScalarType(CInt)
ScalarType(CShort)
ScalarType(CLong)
ScalarType(CLLong)
ScalarType(CIntMax)
ScalarType(CDouble)
ScalarType(CFloat)
ScalarType(Word)
ScalarType(Word16)
ScalarType(Word32)
ScalarType(Word64)
ScalarType(Word8)

instance Integral a => Additive (Ratio a) where
  zero :: Ratio a
zero  = Ratio a
0
  ^+^ :: Ratio a -> Ratio a -> Ratio a
(^+^) = Ratio a -> Ratio a -> Ratio a
forall a. Num a => a -> a -> a
(+)

instance (RealFloat v, Additive v) => Additive (Complex v) where
  zero :: Complex v
zero  = v
forall a. Additive a => a
zero v -> v -> Complex v
forall a. a -> a -> Complex a
:+ v
forall a. Additive a => a
zero
  ^+^ :: Complex v -> Complex v -> Complex v
(^+^) = Complex v -> Complex v -> Complex v
forall a. Num a => a -> a -> a
(+)

-- The 'RealFloat' constraint is unfortunate here. It's due to a
-- questionable decision to place 'RealFloat' into the definition of the
-- 'Complex' /type/, rather than in functions and instances as needed.

instance (Additive u,Additive v) => Additive (u,v) where
  zero :: (u, v)
zero              = (u
forall a. Additive a => a
zero,v
forall a. Additive a => a
zero)
  (u
u,v
v) ^+^ :: (u, v) -> (u, v) -> (u, v)
^+^ (u
u',v
v') = (u
uu -> u -> u
forall a. Additive a => Binop a
^+^u
u',v
vv -> v -> v
forall a. Additive a => Binop a
^+^v
v')

instance (Additive u,Additive v,Additive w)
    => Additive (u,v,w) where
  zero :: (u, v, w)
zero                   = (u
forall a. Additive a => a
zero,v
forall a. Additive a => a
zero,w
forall a. Additive a => a
zero)
  (u
u,v
v,w
w) ^+^ :: (u, v, w) -> (u, v, w) -> (u, v, w)
^+^ (u
u',v
v',w
w') = (u
uu -> u -> u
forall a. Additive a => Binop a
^+^u
u',v
vv -> v -> v
forall a. Additive a => Binop a
^+^v
v',w
ww -> w -> w
forall a. Additive a => Binop a
^+^w
w')

instance (Additive u,Additive v,Additive w,Additive x)
    => Additive (u,v,w,x) where
  zero :: (u, v, w, x)
zero                        = (u
forall a. Additive a => a
zero,v
forall a. Additive a => a
zero,w
forall a. Additive a => a
zero,x
forall a. Additive a => a
zero)
  (u
u,v
v,w
w,x
x) ^+^ :: (u, v, w, x) -> (u, v, w, x) -> (u, v, w, x)
^+^ (u
u',v
v',w
w',x
x') = (u
uu -> u -> u
forall a. Additive a => Binop a
^+^u
u',v
vv -> v -> v
forall a. Additive a => Binop a
^+^v
v',w
ww -> w -> w
forall a. Additive a => Binop a
^+^w
w',x
xx -> x -> x
forall a. Additive a => Binop a
^+^x
x')

type AddF f = (Pointed f, Zip f)

instance KnownNat n => Additive (Finite n) where
  zero :: Finite n
zero = Finite n
0
  ^+^ :: Finite n -> Finite n -> Finite n
(^+^) = Finite n -> Finite n -> Finite n
forall a. Num a => a -> a -> a
(+)

#if 1

#define AdditiveFunctor(f) instance (AddF (f), Additive v) => Additive ((f) v)

AdditiveFunctor((->) a)
AdditiveFunctor(Sum)
AdditiveFunctor(Product)
AdditiveFunctor(U1)
AdditiveFunctor(Par1)
AdditiveFunctor(f :*: g)
AdditiveFunctor(g :.: f)

#else

instance Additive v => Additive (a -> v)
instance Additive v => Additive (Sum     v)
instance Additive v => Additive (Product v)

instance Additive v => Additive (U1 v)
instance Additive v => Additive (Par1 v)
instance (Additive v, AddF f, AddF g) => Additive ((f :*: g) v)
instance (Additive v, AddF f, AddF g) => Additive ((g :.: f) v)

#endif


-- instance (Eq i, Additive v) => Additive (Arr i v) where
--   zero = point zero
--   as ^+^ bs = fmap (uncurry (^+^)) (zipC (as,bs))

-- TODO: Define and use zipWithC (^+^) as bs.

instance (Additive v, KnownNat n) => Additive (Vector n v)

-- Maybe is handled like the Maybe-of-Sum monoid
instance Additive a => Additive (Maybe a) where
  zero :: Maybe a
zero                = Maybe a
forall a. Maybe a
Nothing
  Maybe a
Nothing ^+^ :: Maybe a -> Maybe a -> Maybe a
^+^ Maybe a
b'      = Maybe a
b'
  Maybe a
a' ^+^ Maybe a
Nothing      = Maybe a
a'
  Just a
a' ^+^ Just a
b' = a -> Maybe a
forall a. a -> Maybe a
Just (a
a' a -> a -> a
forall a. Additive a => Binop a
^+^ a
b')

-- -- Memo tries
-- instance (HasTrie u, Additive v) => Additive (u :->: v) where
--   zero  = pure   zero
--   (^+^) = liftA2 (^+^)

-- Experiment
instance Additive Bool where
  -- zero = undefined
  -- _ ^+^ _ = undefined
  zero :: Bool
zero = Bool
False
  ^+^ :: Bool -> Bool -> Bool
(^+^) = Bool -> Bool -> Bool
(||)
  {-# INLINE zero #-}
  {-# INLINE (^+^) #-}

{--------------------------------------------------------------------
    Monoid wrapper
--------------------------------------------------------------------}

-- | Monoid under group addition.  Alternative to the @Sum@ in
-- "Data.Monoid", which uses 'Num' instead of 'Additive'.
newtype Add a = Add { forall a. Add a -> a
getAdd :: a }
  deriving (Add a -> Add a -> Bool
(Add a -> Add a -> Bool) -> (Add a -> Add a -> Bool) -> Eq (Add a)
forall a. Eq a => Add a -> Add a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Add a -> Add a -> Bool
== :: Add a -> Add a -> Bool
$c/= :: forall a. Eq a => Add a -> Add a -> Bool
/= :: Add a -> Add a -> Bool
Eq, Eq (Add a)
Eq (Add a)
-> (Add a -> Add a -> Ordering)
-> (Add a -> Add a -> Bool)
-> (Add a -> Add a -> Bool)
-> (Add a -> Add a -> Bool)
-> (Add a -> Add a -> Bool)
-> (Add a -> Add a -> Add a)
-> (Add a -> Add a -> Add a)
-> Ord (Add a)
Add a -> Add a -> Bool
Add a -> Add a -> Ordering
Add a -> Add a -> Add a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Add a)
forall a. Ord a => Add a -> Add a -> Bool
forall a. Ord a => Add a -> Add a -> Ordering
forall a. Ord a => Add a -> Add a -> Add a
$ccompare :: forall a. Ord a => Add a -> Add a -> Ordering
compare :: Add a -> Add a -> Ordering
$c< :: forall a. Ord a => Add a -> Add a -> Bool
< :: Add a -> Add a -> Bool
$c<= :: forall a. Ord a => Add a -> Add a -> Bool
<= :: Add a -> Add a -> Bool
$c> :: forall a. Ord a => Add a -> Add a -> Bool
> :: Add a -> Add a -> Bool
$c>= :: forall a. Ord a => Add a -> Add a -> Bool
>= :: Add a -> Add a -> Bool
$cmax :: forall a. Ord a => Add a -> Add a -> Add a
max :: Add a -> Add a -> Add a
$cmin :: forall a. Ord a => Add a -> Add a -> Add a
min :: Add a -> Add a -> Add a
Ord, ReadPrec [Add a]
ReadPrec (Add a)
Int -> ReadS (Add a)
ReadS [Add a]
(Int -> ReadS (Add a))
-> ReadS [Add a]
-> ReadPrec (Add a)
-> ReadPrec [Add a]
-> Read (Add a)
forall a. Read a => ReadPrec [Add a]
forall a. Read a => ReadPrec (Add a)
forall a. Read a => Int -> ReadS (Add a)
forall a. Read a => ReadS [Add a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Add a)
readsPrec :: Int -> ReadS (Add a)
$creadList :: forall a. Read a => ReadS [Add a]
readList :: ReadS [Add a]
$creadPrec :: forall a. Read a => ReadPrec (Add a)
readPrec :: ReadPrec (Add a)
$creadListPrec :: forall a. Read a => ReadPrec [Add a]
readListPrec :: ReadPrec [Add a]
Read, Int -> Add a -> ShowS
[Add a] -> ShowS
Add a -> String
(Int -> Add a -> ShowS)
-> (Add a -> String) -> ([Add a] -> ShowS) -> Show (Add a)
forall a. Show a => Int -> Add a -> ShowS
forall a. Show a => [Add a] -> ShowS
forall a. Show a => Add a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Add a -> ShowS
showsPrec :: Int -> Add a -> ShowS
$cshow :: forall a. Show a => Add a -> String
show :: Add a -> String
$cshowList :: forall a. Show a => [Add a] -> ShowS
showList :: [Add a] -> ShowS
Show, Add a
Add a -> Add a -> Bounded (Add a)
forall a. a -> a -> Bounded a
forall a. Bounded a => Add a
$cminBound :: forall a. Bounded a => Add a
minBound :: Add a
$cmaxBound :: forall a. Bounded a => Add a
maxBound :: Add a
Bounded)

instance HasRep (Add a) where
  type Rep (Add a) = a
  abst :: Rep (Add a) -> Add a
abst = a -> Add a
Rep (Add a) -> Add a
forall a. a -> Add a
Add
  repr :: Add a -> Rep (Add a)
repr = Add a -> a
Add a -> Rep (Add a)
forall a. Add a -> a
getAdd

instance Functor Add where fmap :: forall a b. (a -> b) -> Add a -> Add b
fmap = (a -> b) -> Add a -> Add b
(Rep (Add a) -> Rep (Add b)) -> Add a -> Add b
forall p q. (HasRep p, HasRep q) => (Rep p -> Rep q) -> p -> q
inAbst

instance Applicative Add where
  pure :: forall a. a -> Add a
pure  = a -> Add a
Rep (Add a) -> Add a
forall a. HasRep a => Rep a -> a
abst
  <*> :: forall a b. Add (a -> b) -> Add a -> Add b
(<*>) = (Rep (Add (a -> b)) -> Rep (Add a) -> Rep (Add b))
-> Add (a -> b) -> Add a -> Add b
forall p q r.
(HasRep p, HasRep q, HasRep r) =>
(Rep p -> Rep q -> Rep r) -> p -> q -> r
inAbst2 Rep (Add (a -> b)) -> Rep (Add a) -> Rep (Add b)
(Rep (Add a) -> Rep (Add b)) -> Rep (Add a) -> Rep (Add b)
forall a b. (a -> b) -> a -> b
($)

instance Additive a => Semigroup (Add a) where
  <> :: Add a -> Add a -> Add a
(<>) = (Rep (Add a) -> Rep (Add a) -> Rep (Add a))
-> Add a -> Add a -> Add a
forall p q r.
(HasRep p, HasRep q, HasRep r) =>
(Rep p -> Rep q -> Rep r) -> p -> q -> r
inAbst2 a -> a -> a
Rep (Add a) -> Rep (Add a) -> Rep (Add a)
forall a. Additive a => Binop a
(^+^)

instance Additive a => Monoid (Add a) where
  mempty :: Add a
mempty  = Rep (Add a) -> Add a
forall a. HasRep a => Rep a -> a
abst a
Rep (Add a)
forall a. Additive a => a
zero
  mappend :: Add a -> Add a -> Add a
mappend = Add a -> Add a -> Add a
forall a. Semigroup a => a -> a -> a
(<>)

instance Additive a => Additive (Add a) where
  zero :: Add a
zero  = Add a
forall a. Monoid a => a
mempty
  ^+^ :: Add a -> Add a -> Add a
(^+^) = Add a -> Add a -> Add a
forall a. Monoid a => a -> a -> a
mappend

-- sumA' :: (Foldable h, Additive a) => h a -> a
-- sumA' = getAdd . foldMap Add

-- Enables translation of sumA to jamPF in AltCat.
type SummableF h = (Representable h, Eq (Rep h), Zip h, Pointed h, Foldable h)

class    SummableF h => Summable h
instance SummableF h => Summable h

-- The constraint ‘Representable h’
--   is no smaller than the instance head
-- (Use UndecidableInstances to permit this)

sumA :: (
  -- Summable h, Additive a
  Foldable h, Additive a
  ) => h a -> a
sumA :: forall (h :: * -> *) a. (Foldable h, Additive a) => h a -> a
sumA = Add a -> a
forall a. Add a -> a
getAdd (Add a -> a) -> (h a -> Add a) -> h a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Add a) -> h a -> Add a
forall m a. Monoid m => (a -> m) -> h a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Add a
forall a. a -> Add a
Add
{-# OPINLINE sumA #-}