module Plutarch.Internal.Case (punsafeCase) where

import Data.Kind (Type)
import Data.Semialign (unzipWith)
import Plutarch.Builtin.Opaque (POpaque)
import Plutarch.Internal.Term (
  RawTerm (RCase),
  S,
  Term (Term),
  TermResult (TermResult),
  asRawTerm,
 )

{- | Construct a @Case@ statement in UPLC. The first argument is what will be
matched on, while the second argument will be used as handlers.

= Important note

No attempt will (or even /can/) be made to check that the handlers have
correct types, or that the number of handlers is appropriate for the type
being handled. Crashes or misbehaviour can and will occur if you get this
wrong!

@since 1.13.0
-}
punsafeCase ::
  forall (a :: S -> Type) (b :: S -> Type) (s :: S).
  Term s a ->
  [Term s POpaque] ->
  Term s b
punsafeCase :: forall (a :: S -> Type) (b :: S -> Type) (s :: S).
Term s a -> [Term s POpaque] -> Term s b
punsafeCase Term s a
scrutinee [Term s POpaque]
handlers = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall a b. (a -> b) -> a -> b
$ do
  TermResult RawTerm
rawScrutinee [HoistedTerm]
depsScrutinee <- Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
scrutinee
  ([RawTerm]
rawHandlers, [[HoistedTerm]]
depsHandlers) <- (TermResult -> (RawTerm, [HoistedTerm]))
-> [TermResult] -> ([RawTerm], [[HoistedTerm]])
forall c a b. (c -> (a, b)) -> [c] -> ([a], [b])
forall (f :: Type -> Type) c a b.
Unzip f =>
(c -> (a, b)) -> f c -> (f a, f b)
unzipWith (\(TermResult RawTerm
x [HoistedTerm]
y) -> (RawTerm
x, [HoistedTerm]
y)) ([TermResult] -> ([RawTerm], [[HoistedTerm]]))
-> ExceptT Text (RWS TermEnv () ()) [TermResult]
-> ExceptT Text (RWS TermEnv () ()) ([RawTerm], [[HoistedTerm]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term s POpaque -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [Term s POpaque]
-> ExceptT Text (RWS TermEnv () ()) [TermResult]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term s POpaque -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm [Term s POpaque]
handlers
  let allDeps :: [HoistedTerm]
allDeps = [HoistedTerm]
depsScrutinee [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> [[HoistedTerm]] -> [HoistedTerm]
forall a. Monoid a => [a] -> a
mconcat [[HoistedTerm]]
depsHandlers
  TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RCase RawTerm
rawScrutinee [RawTerm]
rawHandlers) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ [HoistedTerm]
allDeps