{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
module PlutusIR.Transform.RewriteRules.UnConstrConstrData
( unConstrConstrData
) where
import PlutusCore.Default
import PlutusCore.Quote
import PlutusIR
import PlutusIR.Analysis.Builtins
import PlutusIR.Analysis.VarInfo
import PlutusIR.Transform.RewriteRules.Common
unConstrConstrData :: (MonadQuote m, t ~ Term tyname Name DefaultUni DefaultFun a, Monoid a)
=> BuiltinsInfo DefaultUni DefaultFun
-> VarsInfo tyname Name DefaultUni a
-> t
-> m t
unConstrConstrData :: forall (m :: * -> *) t tyname a.
(MonadQuote m, t ~ Term tyname Name DefaultUni DefaultFun a,
Monoid a) =>
BuiltinsInfo DefaultUni DefaultFun
-> VarsInfo tyname Name DefaultUni a -> t -> m t
unConstrConstrData BuiltinsInfo DefaultUni DefaultFun
binfo VarsInfo tyname Name DefaultUni a
vinfo t
t = case t
t of
(A (I (I (B DefaultFun
builtin) Type tyname DefaultUni a
tyFst) Type tyname DefaultUni a
tySnd)
(A (B DefaultFun
UnConstrData) (A (A (B DefaultFun
ConstrData) Term tyname Name DefaultUni DefaultFun a
arg1) Term tyname Name DefaultUni DefaultFun a
arg2))) ->
case DefaultFun
builtin of
DefaultFun
SndPair -> (Type tyname DefaultUni a
tyFst,Term tyname Name DefaultUni DefaultFun a
arg1) (Type tyname DefaultUni a,
Term tyname Name DefaultUni DefaultFun a)
-> Term tyname Name DefaultUni DefaultFun a
-> m (Term tyname Name DefaultUni DefaultFun a)
`seQ` Term tyname Name DefaultUni DefaultFun a
arg2
DefaultFun
FstPair -> do
(Term tyname Name DefaultUni DefaultFun a
genVar, Term tyname Name DefaultUni DefaultFun a
-> Term tyname Name DefaultUni DefaultFun a
genLetIn) <- Type tyname DefaultUni a
-> Term tyname Name DefaultUni DefaultFun a
-> m (Term tyname Name DefaultUni DefaultFun a,
Term tyname Name DefaultUni DefaultFun a
-> Term tyname Name DefaultUni DefaultFun a)
forall (m :: * -> *) (t :: * -> *) tyname (uni :: * -> *) fun a.
(MonadQuote m, TermLike t tyname Name uni fun, Monoid a) =>
Type tyname uni a -> t a -> m (t a, t a -> t a)
mkFreshTermLet Type tyname DefaultUni a
tyFst Term tyname Name DefaultUni DefaultFun a
arg1
Term tyname Name DefaultUni DefaultFun a -> t
Term tyname Name DefaultUni DefaultFun a
-> Term tyname Name DefaultUni DefaultFun a
genLetIn (Term tyname Name DefaultUni DefaultFun a -> t)
-> m (Term tyname Name DefaultUni DefaultFun a) -> m t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Type tyname DefaultUni a
tySnd, Term tyname Name DefaultUni DefaultFun a
arg2) (Type tyname DefaultUni a,
Term tyname Name DefaultUni DefaultFun a)
-> Term tyname Name DefaultUni DefaultFun a
-> m (Term tyname Name DefaultUni DefaultFun a)
`seQ` Term tyname Name DefaultUni DefaultFun a
genVar
DefaultFun
_ -> t -> m t
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t
t
_ -> t -> m t
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t
where
infixr 5 `seQ`
seQ :: (Type tyname DefaultUni a,
Term tyname Name DefaultUni DefaultFun a)
-> Term tyname Name DefaultUni DefaultFun a
-> m (Term tyname Name DefaultUni DefaultFun a)
seQ = BuiltinsInfo DefaultUni DefaultFun
-> VarsInfo tyname Name DefaultUni a
-> (Type tyname DefaultUni a,
Term tyname Name DefaultUni DefaultFun a)
-> Term tyname Name DefaultUni DefaultFun a
-> m (Term tyname Name DefaultUni DefaultFun a)
forall (m :: * -> *) a (uni :: * -> *) fun tyname.
(MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) =>
BuiltinsInfo uni fun
-> VarsInfo tyname Name uni a
-> (Type tyname uni a, Term tyname Name uni fun a)
-> Term tyname Name uni fun a
-> m (Term tyname Name uni fun a)
seqP BuiltinsInfo DefaultUni DefaultFun
binfo VarsInfo tyname Name DefaultUni a
vinfo