{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | Provide generic `Act` instances, in two cases
--
--   data Product a b = Product a b
--
--   instance Act (Last a) a where
--     act (Last Nothing)  a = a
--     act (Last (Just a)) _ = a
--
--   instance Act (Last a) (Product a) where
--     act = gact
--
-- or where two product are matched piecewise (e.g. field by field)
--
--   instance Act (Last a) (Identity a) where
--     act (Last Nothing)  a = a
--     act (Last (Just a)) _ = Identity a
--
--   data Product' f = Product' (f a) (f b)
--     derive Generic
--
--   instance Act (Product' Last) (Product' Identity) where
--     act = gpact
--   
module Data.Act.Generic
  ( gact
  , GenericAct (..)
  , gpact
  ) where

import Data.Act
import GHC.Generics

-- | Action of `s` on `a` via `Rep a`.
--
gact :: (Generic a, GAct s (Rep a))
     => s -> a -> a
gact :: forall a s. (Generic a, GAct s (Rep a)) => s -> a -> a
gact s
s a
a = Rep a (ZonkAny 1) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (s
s s -> Rep a (ZonkAny 1) -> Rep a (ZonkAny 1)
forall p. s -> Rep a p -> Rep a p
forall s (g :: * -> *) p. GAct s g => s -> g p -> g p
`gact'` a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
a)

class GAct s g where
  gact' :: s -> g p -> g p

instance GAct s U1 where
  gact' :: forall p. s -> U1 p -> U1 p
gact' s
_ U1 p
_ = U1 p
forall k (p :: k). U1 p
U1
  
instance GAct s V1 where
  gact' :: forall p. s -> V1 p -> V1 p
gact' s
s V1 p
a = s
s s -> V1 p -> V1 p
forall a b. a -> b -> b
`seq` V1 p
a V1 p -> V1 p -> V1 p
forall a b. a -> b -> b
`seq` [Char] -> V1 p
forall a. HasCallStack => [Char] -> a
error [Char]
"GAct.V1: gact'"

instance Act s a => GAct s (K1 i a) where
  gact' :: forall p. s -> K1 i a p -> K1 i a p
gact' s
s (K1 a
a) = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (s
s s -> a -> a
forall s x. Act s x => s -> x -> x
`act` a
a)

instance GAct s f => GAct s (M1 i' c' f) where
  gact' :: forall p. s -> M1 i' c' f p -> M1 i' c' f p
gact' s
s (M1 f p
a) = f p -> M1 i' c' f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (s
s s -> f p -> f p
forall p. s -> f p -> f p
forall s (g :: * -> *) p. GAct s g => s -> g p -> g p
`gact'` f p
a)

instance (GAct s f, GAct s g) => GAct s (f :*: g) where
  gact' :: forall p. s -> (:*:) f g p -> (:*:) f g p
gact' s
s (f p
a0 :*: g p
a1) = s
s s -> f p -> f p
forall p. s -> f p -> f p
forall s (g :: * -> *) p. GAct s g => s -> g p -> g p
`gact'` f p
a0 f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: s
s s -> g p -> g p
forall p. s -> g p -> g p
forall s (g :: * -> *) p. GAct s g => s -> g p -> g p
`gact'` g p
a1

instance (GAct s f, GAct s g) => GAct s (f :+: g) where
  gact' :: forall p. s -> (:+:) f g p -> (:+:) f g p
gact' s
s (L1 f p
a) = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (s
s s -> f p -> f p
forall p. s -> f p -> f p
forall s (g :: * -> *) p. GAct s g => s -> g p -> g p
`gact'` f p
a)
  gact' s
s (R1 g p
a) = g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (s
s s -> g p -> g p
forall p. s -> g p -> g p
forall s (g :: * -> *) p. GAct s g => s -> g p -> g p
`gact'` g p
a)

-- | A newtype wrapper for deriving via.
--
newtype GenericAct s a = GenericAct { forall s a. GenericAct s a -> a
getGenericAct :: a }

instance (Generic s, Generic a, GAct s (Rep a), Semigroup s) => Act s (GenericAct s a) where
  act :: s -> GenericAct s a -> GenericAct s a
act s
s (GenericAct a
a) = a -> GenericAct s a
forall s a. a -> GenericAct s a
GenericAct (s
s s -> a -> a
forall a s. (Generic a, GAct s (Rep a)) => s -> a -> a
`gact` a
a)


-- | Action of `s` on `a` via action of `Rep s` on `Rep a`.
--
gpact :: (Generic s, Generic a, GPAct (Rep s) (Rep a))
     => s -> a -> a
gpact :: forall s a.
(Generic s, Generic a, GPAct (Rep s) (Rep a)) =>
s -> a -> a
gpact s
s a
a = Rep a (ZonkAny 0) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (s -> Rep s (ZonkAny 0)
forall x. s -> Rep s x
forall a x. Generic a => a -> Rep a x
from s
s Rep s (ZonkAny 0) -> Rep a (ZonkAny 0) -> Rep a (ZonkAny 0)
forall p. Rep s p -> Rep a p -> Rep a p
forall (f :: * -> *) (g :: * -> *) p.
GPAct f g =>
f p -> g p -> g p
`gpact'` a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
a)

class GPAct f g where
  gpact' :: f p -> g p -> g p

instance GPAct s U1 where
  gpact' :: forall p. s p -> U1 p -> U1 p
gpact' s p
_ U1 p
_ = U1 p
forall k (p :: k). U1 p
U1
  
instance GPAct s V1 where
  gpact' :: forall p. s p -> V1 p -> V1 p
gpact' s p
s V1 p
a = s p
s s p -> V1 p -> V1 p
forall a b. a -> b -> b
`seq` V1 p
a V1 p -> V1 p -> V1 p
forall a b. a -> b -> b
`seq` [Char] -> V1 p
forall a. HasCallStack => [Char] -> a
error [Char]
"GPAct.V1: gact'"

instance Act s a => GPAct (K1 i' s) (K1 i a) where
  gpact' :: forall p. K1 i' s p -> K1 i a p -> K1 i a p
gpact' (K1 s
s) (K1 a
a) = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (s
s s -> a -> a
forall s x. Act s x => s -> x -> x
`act` a
a)

instance GPAct s f => GPAct (M1 i' c' s) (M1 i' c' f) where
  gpact' :: forall p. M1 i' c' s p -> M1 i' c' f p -> M1 i' c' f p
gpact' (M1 s p
s) (M1 f p
a) = f p -> M1 i' c' f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (s p
s s p -> f p -> f p
forall p. s p -> f p -> f p
forall (f :: * -> *) (g :: * -> *) p.
GPAct f g =>
f p -> g p -> g p
`gpact'` f p
a)

instance (GPAct s f, GPAct s' f') => GPAct (s :*: s') (f :*: f') where
  gpact' :: forall p. (:*:) s s' p -> (:*:) f f' p -> (:*:) f f' p
gpact' (s p
s0 :*: s' p
s1) (f p
a0 :*: f' p
a1) = s p
s0 s p -> f p -> f p
forall p. s p -> f p -> f p
forall (f :: * -> *) (g :: * -> *) p.
GPAct f g =>
f p -> g p -> g p
`gpact'` f p
a0 f p -> f' p -> (:*:) f f' p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: s' p
s1 s' p -> f' p -> f' p
forall p. s' p -> f' p -> f' p
forall (f :: * -> *) (g :: * -> *) p.
GPAct f g =>
f p -> g p -> g p
`gpact'` f' p
a1

-- we don't provide `GPAct` for `:+:`