{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

module Plutarch.Internal.Newtype (PlutusTypeNewtype) where

import Generics.SOP qualified as SOP
import Plutarch.Internal.Generic (PCode, PGeneric, gpfrom, gpto)
import Plutarch.Internal.PlutusType (
  DerivedPInner,
  PlutusTypeStrat,
  PlutusTypeStratConstraint,
  derivedPCon,
  derivedPMatch,
 )
import Plutarch.Internal.Term (PType)

data PlutusTypeNewtype

class (PGeneric a, PCode a ~ '[ '[GetPNewtype a]]) => Helper (a :: PType)
instance (PGeneric a, PCode a ~ '[ '[GetPNewtype a]]) => Helper (a :: PType)

instance PlutusTypeStrat PlutusTypeNewtype where
  type PlutusTypeStratConstraint PlutusTypeNewtype = Helper
  type DerivedPInner PlutusTypeNewtype a = GetPNewtype a
  derivedPCon :: forall (a :: PType) (s :: S).
(DerivePlutusType a,
 (DPTStrat a :: Type) ~ (PlutusTypeNewtype :: Type)) =>
a s -> Term s (DerivedPInner PlutusTypeNewtype a)
derivedPCon a s
x = case a s -> SOP @PType (Term s) (PCode a)
forall (a :: PType) (s :: S).
PGeneric a =>
a s -> SOP @PType (Term s) (PCode a)
gpfrom a s
x of
    SOP.SOP (SOP.Z (Term s x
x SOP.:* NP @PType (Term s) xs
SOP.Nil)) -> Term s x
Term s (DerivedPInner PlutusTypeNewtype a)
x
    SOP.SOP (SOP.S NS @[PType] (NP @PType (Term s)) xs
x) -> case NS @[PType] (NP @PType (Term s)) xs
x of {}
  derivedPMatch :: forall (a :: PType) (s :: S) (b :: PType).
(DerivePlutusType a,
 (DPTStrat a :: Type) ~ (PlutusTypeNewtype :: Type)) =>
Term s (DerivedPInner PlutusTypeNewtype a)
-> (a s -> Term s b) -> Term s b
derivedPMatch Term s (DerivedPInner PlutusTypeNewtype a)
x a s -> Term s b
f = a s -> Term s b
f (SOP @PType (Term s) (PCode a) -> a s
forall (a :: PType) (s :: S).
PGeneric a =>
SOP @PType (Term s) (PCode a) -> a s
gpto (SOP @PType (Term s) (PCode a) -> a s)
-> SOP @PType (Term s) (PCode a) -> a s
forall a b. (a -> b) -> a -> b
$ NS @[PType] (NP @PType (Term s)) (PCode a)
-> SOP @PType (Term s) (PCode a)
forall k (f :: k -> Type) (xss :: [[k]]).
NS @[k] (NP @k f) xss -> SOP @k f xss
SOP.SOP (NS @[PType] (NP @PType (Term s)) (PCode a)
 -> SOP @PType (Term s) (PCode a))
-> NS @[PType] (NP @PType (Term s)) (PCode a)
-> SOP @PType (Term s) (PCode a)
forall a b. (a -> b) -> a -> b
$ NP
  @PType (Term s) ((':) @PType (GetPNewtype' (PCode a)) ('[] @PType))
-> NS
     @[PType]
     (NP @PType (Term s))
     ((':)
        @[PType]
        ((':) @PType (GetPNewtype' (PCode a)) ('[] @PType))
        ('[] @[PType]))
forall {k} (a :: k -> Type) (x :: k) (xs :: [k]).
a x -> NS @k a ((':) @k x xs)
SOP.Z (NP
   @PType (Term s) ((':) @PType (GetPNewtype' (PCode a)) ('[] @PType))
 -> NS
      @[PType]
      (NP @PType (Term s))
      ((':)
         @[PType]
         ((':) @PType (GetPNewtype' (PCode a)) ('[] @PType))
         ('[] @[PType])))
-> NP
     @PType (Term s) ((':) @PType (GetPNewtype' (PCode a)) ('[] @PType))
-> NS
     @[PType]
     (NP @PType (Term s))
     ((':)
        @[PType]
        ((':) @PType (GetPNewtype' (PCode a)) ('[] @PType))
        ('[] @[PType]))
forall a b. (a -> b) -> a -> b
$ Term s (DerivedPInner PlutusTypeNewtype a)
x Term s (DerivedPInner PlutusTypeNewtype a)
-> NP @PType (Term s) ('[] @PType)
-> NP
     @PType
     (Term s)
     ((':) @PType (DerivedPInner PlutusTypeNewtype a) ('[] @PType))
forall {k} (a :: k -> Type) (x :: k) (xs :: [k]).
a x -> NP @k a xs -> NP @k a ((':) @k x xs)
SOP.:* NP @PType (Term s) ('[] @PType)
forall {k} (a :: k -> Type). NP @k a ('[] @k)
SOP.Nil)

type family GetPNewtype' (a :: [[PType]]) :: PType where
  GetPNewtype' '[ '[a]] = a

type family GetPNewtype (a :: PType) :: PType where
  GetPNewtype a = GetPNewtype' (PCode a)