{-# LANGUAGE QuantifiedConstraints #-}

module Plutarch.Extra.Deriving (
  FromPInner (..),
) where

import Data.Coerce (coerce)
import Data.Semigroup (sconcat, stimes)
import Plutarch.Unsafe (punsafeDowncast)

{- | Derivation helper to obtain 'Semigroup' and 'Monoid' instances for a type
 by way of its 'PInner' representation.

 = Important notes

 Do /not/ use this helper for any type @a@ where @'PInner' a ~ a@. This will
 loop the compiler.

 Furthermore, only use this derivation if 'Semigroup' and 'Monoid' methods
 cannot produce invalid values of the type being derived for. For example, if
 '<>' between 'PInner's can produce an invalid value of your type, deriving in
 this manner will allow such values to exist.

 @since 3.14.0
-}
newtype FromPInner (a :: S -> Type) (s :: S)
  = FromPInner (Term s a)

-- | @since 3.14.0
instance
  (PInnerSemigroup a (PInner a)) =>
  Semigroup (FromPInner a s)
  where
  {-# INLINEABLE (<>) #-}
  FromPInner Term s a
t <> :: FromPInner a s -> FromPInner a s -> FromPInner a s
<> FromPInner Term s a
t' = forall (a :: PType) (s :: S). Term s a -> FromPInner a s
FromPInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S) (a :: PType). Term s (PInner a) -> Term s a
punsafeDowncast forall a b. (a -> b) -> a -> b
$ forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto Term s a
t forall a. Semigroup a => a -> a -> a
<> forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto Term s a
t'
  {-# INLINEABLE stimes #-}
  stimes :: forall b. Integral b => b -> FromPInner a s -> FromPInner a s
stimes b
reps (FromPInner Term s a
t) =
    forall (a :: PType) (s :: S). Term s a -> FromPInner a s
FromPInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S) (a :: PType). Term s (PInner a) -> Term s a
punsafeDowncast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes b
reps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto forall a b. (a -> b) -> a -> b
$ Term s a
t
  {-# INLINEABLE sconcat #-}
  sconcat :: NonEmpty (FromPInner a s) -> FromPInner a s
sconcat = forall (a :: PType) (s :: S). Term s a -> FromPInner a s
FromPInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S) (a :: PType). Term s (PInner a) -> Term s a
punsafeDowncast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semigroup a => NonEmpty a -> a
sconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce)

-- | @since 3.14.0
instance
  (PInnerMonoid a (PInner a)) =>
  Monoid (FromPInner a s)
  where
  {-# INLINEABLE mempty #-}
  mempty :: FromPInner a s
mempty = forall (a :: PType) (s :: S). Term s a -> FromPInner a s
FromPInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S) (a :: PType). Term s (PInner a) -> Term s a
punsafeDowncast forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty

-- Helpers

-- Class synonym instances to get around the problem described in this issue
-- here: https://gitlab.haskell.org/ghc/ghc/-/issues/17959
--
-- More specifically, if we tried to write:
--
-- instance (forall s . Semigroup (Term s (PInner a))) => ...
--
-- GHC would reject this. However, using something like
--
-- instance (PInnerSemigroup a (PInner a)) => ...
--
-- works correctly.
class
  (b ~ PInner a, forall (s :: S). Semigroup (Term s b)) =>
  PInnerSemigroup a b

instance
  (b ~ PInner a, forall (s :: S). Semigroup (Term s b)) =>
  PInnerSemigroup a b

class
  (b ~ PInner a, forall (s :: S). Monoid (Term s b)) =>
  PInnerMonoid a b

instance
  (b ~ PInner a, forall (s :: S). Monoid (Term s b)) =>
  PInnerMonoid a b