{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module UntypedPlutusCore.Transform.Inline (inline, InlineHints (..)) where
import PlutusCore qualified as PLC
import PlutusCore.Annotation
import PlutusCore.Builtin qualified as PLC
import PlutusCore.MkPlc (mkIterApp)
import PlutusCore.Name.Unique
import PlutusCore.Name.UniqueMap qualified as UMap
import PlutusCore.Quote
import PlutusCore.Rename (Dupable, dupable, liftDupable)
import PlutusPrelude
import UntypedPlutusCore.Analysis.Usages qualified as Usages
import UntypedPlutusCore.Core qualified as UPLC
import UntypedPlutusCore.Core.Plated
import UntypedPlutusCore.Core.Type
import UntypedPlutusCore.MkUPlc
import UntypedPlutusCore.Purity
import UntypedPlutusCore.Rename ()
import UntypedPlutusCore.Size
import UntypedPlutusCore.Subst
import Control.Lens hiding (Strict)
import Control.Monad.Extra
import Control.Monad.Reader
import Control.Monad.State
import Witherable (wither)
newtype InlineTerm name uni fun a = Done (Dupable (Term name uni fun a))
newtype TermEnv name uni fun a = TermEnv
{forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> UniqueMap TermUnique (InlineTerm name uni fun a)
_unTermEnv :: PLC.UniqueMap TermUnique (InlineTerm name uni fun a)}
deriving newtype (NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
(TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a)
-> (NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a)
-> (forall b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a)
-> Semigroup (TermEnv name uni fun a)
forall b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall name (uni :: * -> *) fun a.
NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
forall name (uni :: * -> *) fun a b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
$c<> :: forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
<> :: TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
$csconcat :: forall name (uni :: * -> *) fun a.
NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
sconcat :: NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
$cstimes :: forall name (uni :: * -> *) fun a b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
stimes :: forall b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
Semigroup, Semigroup (TermEnv name uni fun a)
TermEnv name uni fun a
Semigroup (TermEnv name uni fun a) =>
TermEnv name uni fun a
-> (TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a)
-> ([TermEnv name uni fun a] -> TermEnv name uni fun a)
-> Monoid (TermEnv name uni fun a)
[TermEnv name uni fun a] -> TermEnv name uni fun a
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall name (uni :: * -> *) fun a.
Semigroup (TermEnv name uni fun a)
forall name (uni :: * -> *) fun a. TermEnv name uni fun a
forall name (uni :: * -> *) fun a.
[TermEnv name uni fun a] -> TermEnv name uni fun a
forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
$cmempty :: forall name (uni :: * -> *) fun a. TermEnv name uni fun a
mempty :: TermEnv name uni fun a
$cmappend :: forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
mappend :: TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
$cmconcat :: forall name (uni :: * -> *) fun a.
[TermEnv name uni fun a] -> TermEnv name uni fun a
mconcat :: [TermEnv name uni fun a] -> TermEnv name uni fun a
Monoid)
newtype Subst name uni fun a = Subst {forall name (uni :: * -> *) fun a.
Subst name uni fun a -> TermEnv name uni fun a
_termEnv :: TermEnv name uni fun a}
deriving stock ((forall x. Subst name uni fun a -> Rep (Subst name uni fun a) x)
-> (forall x. Rep (Subst name uni fun a) x -> Subst name uni fun a)
-> Generic (Subst name uni fun a)
forall x. Rep (Subst name uni fun a) x -> Subst name uni fun a
forall x. Subst name uni fun a -> Rep (Subst name uni fun a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall name (uni :: * -> *) fun a x.
Rep (Subst name uni fun a) x -> Subst name uni fun a
forall name (uni :: * -> *) fun a x.
Subst name uni fun a -> Rep (Subst name uni fun a) x
$cfrom :: forall name (uni :: * -> *) fun a x.
Subst name uni fun a -> Rep (Subst name uni fun a) x
from :: forall x. Subst name uni fun a -> Rep (Subst name uni fun a) x
$cto :: forall name (uni :: * -> *) fun a x.
Rep (Subst name uni fun a) x -> Subst name uni fun a
to :: forall x. Rep (Subst name uni fun a) x -> Subst name uni fun a
Generic)
deriving newtype (NonEmpty (Subst name uni fun a) -> Subst name uni fun a
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
(Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a)
-> (NonEmpty (Subst name uni fun a) -> Subst name uni fun a)
-> (forall b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a)
-> Semigroup (Subst name uni fun a)
forall b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall name (uni :: * -> *) fun a.
NonEmpty (Subst name uni fun a) -> Subst name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
forall name (uni :: * -> *) fun a b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
$c<> :: forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
<> :: Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
$csconcat :: forall name (uni :: * -> *) fun a.
NonEmpty (Subst name uni fun a) -> Subst name uni fun a
sconcat :: NonEmpty (Subst name uni fun a) -> Subst name uni fun a
$cstimes :: forall name (uni :: * -> *) fun a b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
stimes :: forall b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
Semigroup, Semigroup (Subst name uni fun a)
Subst name uni fun a
Semigroup (Subst name uni fun a) =>
Subst name uni fun a
-> (Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a)
-> ([Subst name uni fun a] -> Subst name uni fun a)
-> Monoid (Subst name uni fun a)
[Subst name uni fun a] -> Subst name uni fun a
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall name (uni :: * -> *) fun a. Semigroup (Subst name uni fun a)
forall name (uni :: * -> *) fun a. Subst name uni fun a
forall name (uni :: * -> *) fun a.
[Subst name uni fun a] -> Subst name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
$cmempty :: forall name (uni :: * -> *) fun a. Subst name uni fun a
mempty :: Subst name uni fun a
$cmappend :: forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
mappend :: Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
$cmconcat :: forall name (uni :: * -> *) fun a.
[Subst name uni fun a] -> Subst name uni fun a
mconcat :: [Subst name uni fun a] -> Subst name uni fun a
Monoid)
makeLenses ''TermEnv
makeLenses ''Subst
data VarInfo name uni fun ann = VarInfo
{ forall name (uni :: * -> *) fun ann.
VarInfo name uni fun ann -> [name]
_varBinders :: [name]
, forall name (uni :: * -> *) fun ann.
VarInfo name uni fun ann -> Term name uni fun ann
_varRhs :: Term name uni fun ann
, forall name (uni :: * -> *) fun ann.
VarInfo name uni fun ann -> InlineTerm name uni fun ann
_varRhsBody :: InlineTerm name uni fun ann
}
makeLenses ''VarInfo
data S name uni fun a = S
{ forall name (uni :: * -> *) fun a.
S name uni fun a -> Subst name uni fun a
_subst :: Subst name uni fun a
, forall name (uni :: * -> *) fun a.
S name uni fun a -> UniqueMap TermUnique (VarInfo name uni fun a)
_vars :: PLC.UniqueMap TermUnique (VarInfo name uni fun a)
}
makeLenses ''S
instance Semigroup (S name uni fun a) where
S Subst name uni fun a
a1 UniqueMap TermUnique (VarInfo name uni fun a)
b1 <> :: S name uni fun a -> S name uni fun a -> S name uni fun a
<> S Subst name uni fun a
a2 UniqueMap TermUnique (VarInfo name uni fun a)
b2 = Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
S (Subst name uni fun a
a1 Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
forall a. Semigroup a => a -> a -> a
<> Subst name uni fun a
a2) (UniqueMap TermUnique (VarInfo name uni fun a)
b1 UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a)
forall a. Semigroup a => a -> a -> a
<> UniqueMap TermUnique (VarInfo name uni fun a)
b2)
instance Monoid (S name uni fun a) where
mempty :: S name uni fun a
mempty = Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
S Subst name uni fun a
forall a. Monoid a => a
mempty UniqueMap TermUnique (VarInfo name uni fun a)
forall a. Monoid a => a
mempty
type ExternalConstraints name uni fun m =
( HasUnique name TermUnique
, Eq name
, PLC.ToBuiltinMeaning uni fun
, MonadQuote m
)
type InliningConstraints name uni fun =
( HasUnique name TermUnique
, Eq name
, PLC.ToBuiltinMeaning uni fun
)
data InlineInfo name fun a = InlineInfo
{ forall name fun a. InlineInfo name fun a -> Usages
_iiUsages :: Usages.Usages
, forall name fun a. InlineInfo name fun a -> InlineHints name a
_iiHints :: InlineHints name a
, forall name fun a.
InlineInfo name fun a -> BuiltinSemanticsVariant fun
_iiBuiltinSemanticsVariant :: PLC.BuiltinSemanticsVariant fun
, forall name fun a. InlineInfo name fun a -> Bool
_iiInlineConstants :: Bool
}
makeLenses ''InlineInfo
type InlineM name uni fun a = ReaderT (InlineInfo name fun a) (StateT (S name uni fun a) Quote)
lookupTerm ::
(HasUnique name TermUnique) =>
name ->
S name uni fun a ->
Maybe (InlineTerm name uni fun a)
lookupTerm :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (InlineTerm name uni fun a)
lookupTerm name
n S name uni fun a
s = name
-> UniqueMap TermUnique (InlineTerm name uni fun a)
-> Maybe (InlineTerm name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> UniqueMap unique a -> Maybe a
UMap.lookupName name
n (UniqueMap TermUnique (InlineTerm name uni fun a)
-> Maybe (InlineTerm name uni fun a))
-> UniqueMap TermUnique (InlineTerm name uni fun a)
-> Maybe (InlineTerm name uni fun a)
forall a b. (a -> b) -> a -> b
$ S name uni fun a
s S name uni fun a
-> Getting
(UniqueMap TermUnique (InlineTerm name uni fun a))
(S name uni fun a)
(UniqueMap TermUnique (InlineTerm name uni fun a))
-> UniqueMap TermUnique (InlineTerm name uni fun a)
forall s a. s -> Getting a s a -> a
^. (Subst name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(Subst name uni fun a))
-> S name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(S name uni fun a)
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(Subst name uni fun a -> f (Subst name uni fun a))
-> S name uni fun a -> f (S name uni fun a)
subst ((Subst name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(Subst name uni fun a))
-> S name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(S name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(UniqueMap TermUnique (InlineTerm name uni fun a)))
-> Subst name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(Subst name uni fun a))
-> Getting
(UniqueMap TermUnique (InlineTerm name uni fun a))
(S name uni fun a)
(UniqueMap TermUnique (InlineTerm name uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermEnv name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(TermEnv name uni fun a))
-> Subst name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(Subst name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
(p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
-> p (Subst name uni fun a) (f (Subst name uni fun a))
termEnv ((TermEnv name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(TermEnv name uni fun a))
-> Subst name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(Subst name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(UniqueMap TermUnique (InlineTerm name uni fun a)))
-> TermEnv name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(TermEnv name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(UniqueMap TermUnique (InlineTerm name uni fun a)))
-> Subst name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(Subst name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniqueMap TermUnique (InlineTerm name uni fun a)
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(UniqueMap TermUnique (InlineTerm name uni fun a)))
-> TermEnv name uni fun a
-> Const
(UniqueMap TermUnique (InlineTerm name uni fun a))
(TermEnv name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
(p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (UniqueMap TermUnique (InlineTerm name uni fun a))
(f (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
unTermEnv
extendTerm ::
(HasUnique name TermUnique) =>
name ->
InlineTerm name uni fun a ->
S name uni fun a ->
S name uni fun a
extendTerm :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> InlineTerm name uni fun a
-> S name uni fun a
-> S name uni fun a
extendTerm name
n InlineTerm name uni fun a
clos S name uni fun a
s = S name uni fun a
s S name uni fun a
-> (S name uni fun a -> S name uni fun a) -> S name uni fun a
forall a b. a -> (a -> b) -> b
& (Subst name uni fun a -> Identity (Subst name uni fun a))
-> S name uni fun a -> Identity (S name uni fun a)
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(Subst name uni fun a -> f (Subst name uni fun a))
-> S name uni fun a -> f (S name uni fun a)
subst ((Subst name uni fun a -> Identity (Subst name uni fun a))
-> S name uni fun a -> Identity (S name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
-> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> Subst name uni fun a -> Identity (Subst name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
-> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> S name uni fun a
-> Identity (S name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermEnv name uni fun a -> Identity (TermEnv name uni fun a))
-> Subst name uni fun a -> Identity (Subst name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
(p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
-> p (Subst name uni fun a) (f (Subst name uni fun a))
termEnv ((TermEnv name uni fun a -> Identity (TermEnv name uni fun a))
-> Subst name uni fun a -> Identity (Subst name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
-> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> TermEnv name uni fun a -> Identity (TermEnv name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
-> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> Subst name uni fun a
-> Identity (Subst name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniqueMap TermUnique (InlineTerm name uni fun a)
-> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> TermEnv name uni fun a -> Identity (TermEnv name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
(p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (UniqueMap TermUnique (InlineTerm name uni fun a))
(f (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
unTermEnv ((UniqueMap TermUnique (InlineTerm name uni fun a)
-> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> S name uni fun a -> Identity (S name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
-> UniqueMap TermUnique (InlineTerm name uni fun a))
-> S name uni fun a
-> S name uni fun a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ name
-> InlineTerm name uni fun a
-> UniqueMap TermUnique (InlineTerm name uni fun a)
-> UniqueMap TermUnique (InlineTerm name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> a -> UniqueMap unique a -> UniqueMap unique a
UMap.insertByName name
n InlineTerm name uni fun a
clos
lookupVarInfo ::
(HasUnique name TermUnique) =>
name ->
S name uni fun a ->
Maybe (VarInfo name uni fun a)
lookupVarInfo :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (VarInfo name uni fun a)
lookupVarInfo name
n S name uni fun a
s = name
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> Maybe (VarInfo name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> UniqueMap unique a -> Maybe a
UMap.lookupName name
n (UniqueMap TermUnique (VarInfo name uni fun a)
-> Maybe (VarInfo name uni fun a))
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> Maybe (VarInfo name uni fun a)
forall a b. (a -> b) -> a -> b
$ S name uni fun a
s S name uni fun a
-> Getting
(UniqueMap TermUnique (VarInfo name uni fun a))
(S name uni fun a)
(UniqueMap TermUnique (VarInfo name uni fun a))
-> UniqueMap TermUnique (VarInfo name uni fun a)
forall s a. s -> Getting a s a -> a
^. Getting
(UniqueMap TermUnique (VarInfo name uni fun a))
(S name uni fun a)
(UniqueMap TermUnique (VarInfo name uni fun a))
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(UniqueMap TermUnique (VarInfo name uni fun a)
-> f (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> f (S name uni fun a)
vars
extendVarInfo ::
(HasUnique name TermUnique) =>
name ->
VarInfo name uni fun a ->
S name uni fun a ->
S name uni fun a
extendVarInfo :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> VarInfo name uni fun a -> S name uni fun a -> S name uni fun a
extendVarInfo name
n VarInfo name uni fun a
info S name uni fun a
s = S name uni fun a
s S name uni fun a
-> (S name uni fun a -> S name uni fun a) -> S name uni fun a
forall a b. a -> (a -> b) -> b
& (UniqueMap TermUnique (VarInfo name uni fun a)
-> Identity (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> Identity (S name uni fun a)
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(UniqueMap TermUnique (VarInfo name uni fun a)
-> f (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> f (S name uni fun a)
vars ((UniqueMap TermUnique (VarInfo name uni fun a)
-> Identity (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> Identity (S name uni fun a))
-> (UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a))
-> S name uni fun a
-> S name uni fun a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ name
-> VarInfo name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> a -> UniqueMap unique a -> UniqueMap unique a
UMap.insertByName name
n VarInfo name uni fun a
info
inline ::
forall name uni fun m a.
(ExternalConstraints name uni fun m) =>
Bool ->
InlineHints name a ->
PLC.BuiltinSemanticsVariant fun ->
Term name uni fun a ->
m (Term name uni fun a)
inline :: forall name (uni :: * -> *) fun (m :: * -> *) a.
ExternalConstraints name uni fun m =>
Bool
-> InlineHints name a
-> BuiltinSemanticsVariant fun
-> Term name uni fun a
-> m (Term name uni fun a)
inline Bool
inlineConstants InlineHints name a
hints BuiltinSemanticsVariant fun
builtinSemanticsVariant Term name uni fun a
t =
Quote (Term name uni fun a) -> m (Term name uni fun a)
forall a. Quote a -> m a
forall (m :: * -> *) a. MonadQuote m => Quote a -> m a
liftQuote (Quote (Term name uni fun a) -> m (Term name uni fun a))
-> Quote (Term name uni fun a) -> m (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ (StateT (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> S name uni fun a -> Quote (Term name uni fun a))
-> S name uni fun a
-> StateT
(S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> Quote (Term name uni fun a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> S name uni fun a -> Quote (Term name uni fun a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT S name uni fun a
forall a. Monoid a => a
mempty (StateT (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> Quote (Term name uni fun a))
-> StateT
(S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> Quote (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
-> InlineInfo name fun a
-> StateT
(S name uni fun a) (QuoteT Identity) (Term name uni fun a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm Term name uni fun a
t) InlineInfo
{ _iiUsages :: Usages
_iiUsages = Term name uni fun a -> Usages
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
Term name uni fun a -> Usages
Usages.termUsages Term name uni fun a
t
, _iiHints :: InlineHints name a
_iiHints = InlineHints name a
hints
, _iiBuiltinSemanticsVariant :: BuiltinSemanticsVariant fun
_iiBuiltinSemanticsVariant = BuiltinSemanticsVariant fun
builtinSemanticsVariant
, _iiInlineConstants :: Bool
_iiInlineConstants = Bool
inlineConstants
}
extractApps :: Term name uni fun a -> Maybe ([UTermDef name uni fun a], Term name uni fun a)
= [Term name uni fun a]
-> Term name uni fun a
-> Maybe
([Def (UVarDecl name a) (Term name uni fun a)],
Term name uni fun a)
forall {name} {uni :: * -> *} {fun} {ann}.
[Term name uni fun ann]
-> Term name uni fun ann
-> Maybe
([Def (UVarDecl name ann) (Term name uni fun ann)],
Term name uni fun ann)
go []
where
go :: [Term name uni fun ann]
-> Term name uni fun ann
-> Maybe
([Def (UVarDecl name ann) (Term name uni fun ann)],
Term name uni fun ann)
go [Term name uni fun ann]
argStack (Apply ann
_ Term name uni fun ann
f Term name uni fun ann
arg) = [Term name uni fun ann]
-> Term name uni fun ann
-> Maybe
([Def (UVarDecl name ann) (Term name uni fun ann)],
Term name uni fun ann)
go (Term name uni fun ann
arg Term name uni fun ann
-> [Term name uni fun ann] -> [Term name uni fun ann]
forall a. a -> [a] -> [a]
: [Term name uni fun ann]
argStack) Term name uni fun ann
f
go [Term name uni fun ann]
argStack Term name uni fun ann
t = [Term name uni fun ann]
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
-> Maybe
([Def (UVarDecl name ann) (Term name uni fun ann)],
Term name uni fun ann)
forall {val} {name} {ann} {uni :: * -> *} {fun}.
[val]
-> [Def (UVarDecl name ann) val]
-> Term name uni fun ann
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
matchArgs [Term name uni fun ann]
argStack [] Term name uni fun ann
t
matchArgs :: [val]
-> [Def (UVarDecl name ann) val]
-> Term name uni fun ann
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
matchArgs (val
arg : [val]
rest) [Def (UVarDecl name ann) val]
acc (LamAbs ann
a name
n Term name uni fun ann
body) =
[val]
-> [Def (UVarDecl name ann) val]
-> Term name uni fun ann
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
matchArgs [val]
rest (UVarDecl name ann -> val -> Def (UVarDecl name ann) val
forall var val. var -> val -> Def var val
Def (ann -> name -> UVarDecl name ann
forall name ann. ann -> name -> UVarDecl name ann
UVarDecl ann
a name
n) val
arg Def (UVarDecl name ann) val
-> [Def (UVarDecl name ann) val] -> [Def (UVarDecl name ann) val]
forall a. a -> [a] -> [a]
: [Def (UVarDecl name ann) val]
acc) Term name uni fun ann
body
matchArgs [] [Def (UVarDecl name ann) val]
acc Term name uni fun ann
t =
if [Def (UVarDecl name ann) val] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Def (UVarDecl name ann) val]
acc then Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
forall a. Maybe a
Nothing else ([Def (UVarDecl name ann) val], Term name uni fun ann)
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
forall a. a -> Maybe a
Just ([Def (UVarDecl name ann) val] -> [Def (UVarDecl name ann) val]
forall a. [a] -> [a]
reverse [Def (UVarDecl name ann) val]
acc, Term name uni fun ann
t)
matchArgs (val
_ : [val]
_) [Def (UVarDecl name ann) val]
_ Term name uni fun ann
_ = Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
forall a. Maybe a
Nothing
restoreApps :: [UTermDef name uni fun a] -> Term name uni fun a -> Term name uni fun a
restoreApps :: forall name (uni :: * -> *) fun a.
[UTermDef name uni fun a]
-> Term name uni fun a -> Term name uni fun a
restoreApps [UTermDef name uni fun a]
defs Term name uni fun a
t = [Term name uni fun a]
-> Term name uni fun a
-> [UTermDef name uni fun a]
-> Term name uni fun a
forall {name} {uni :: * -> *} {fun} {ann}.
[Term name uni fun ann]
-> Term name uni fun ann
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
makeLams [] Term name uni fun a
t ([UTermDef name uni fun a] -> [UTermDef name uni fun a]
forall a. [a] -> [a]
reverse [UTermDef name uni fun a]
defs)
where
makeLams :: [Term name uni fun ann]
-> Term name uni fun ann
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
makeLams [Term name uni fun ann]
args Term name uni fun ann
acc (Def (UVarDecl ann
a name
n) Term name uni fun ann
rhs : [Def (UVarDecl name ann) (Term name uni fun ann)]
rest) = [Term name uni fun ann]
-> Term name uni fun ann
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
makeLams (Term name uni fun ann
rhs Term name uni fun ann
-> [Term name uni fun ann] -> [Term name uni fun ann]
forall a. a -> [a] -> [a]
: [Term name uni fun ann]
args) (ann -> name -> Term name uni fun ann -> Term name uni fun ann
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
LamAbs ann
a name
n Term name uni fun ann
acc) [Def (UVarDecl name ann) (Term name uni fun ann)]
rest
makeLams [Term name uni fun ann]
args Term name uni fun ann
acc [] = [Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
forall {name} {uni :: * -> *} {fun} {ann}.
[Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
makeApps [Term name uni fun ann]
args Term name uni fun ann
acc
makeApps :: [Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
makeApps (Term name uni fun ann
arg : [Term name uni fun ann]
args) Term name uni fun ann
acc = [Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
makeApps [Term name uni fun ann]
args (ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply (Term name uni fun ann -> ann
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> ann
termAnn Term name uni fun ann
acc) Term name uni fun ann
acc Term name uni fun ann
arg)
makeApps [] Term name uni fun ann
acc = Term name uni fun ann
acc
processTerm ::
forall name uni fun a.
(InliningConstraints name uni fun) =>
Term name uni fun a ->
InlineM name uni fun a (Term name uni fun a)
processTerm :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm = Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
handleTerm
where
handleTerm :: Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
handleTerm :: Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
handleTerm = \case
v :: Term name uni fun a
v@(Var a
_ name
n) -> Term name uni fun a
-> Maybe (Term name uni fun a) -> Term name uni fun a
forall a. a -> Maybe a -> a
fromMaybe Term name uni fun a
v (Maybe (Term name uni fun a) -> Term name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (Term name uni fun a))
-> InlineM name uni fun a (Term name uni fun a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> name
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (Term name uni fun a))
substName name
n
(Term name uni fun a
-> Maybe ([UTermDef name uni fun a], Term name uni fun a)
forall name (uni :: * -> *) fun a.
Term name uni fun a
-> Maybe ([UTermDef name uni fun a], Term name uni fun a)
extractApps -> Just ([UTermDef name uni fun a]
bs, Term name uni fun a
t)) -> do
[UTermDef name uni fun a]
bs' <- (UTermDef name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (UTermDef name uni fun a)))
-> [UTermDef name uni fun a]
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
[UTermDef name uni fun a]
forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f (Maybe b)) -> [a] -> f [b]
wither (Term name uni fun a
-> UTermDef name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (UTermDef name uni fun a))
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> UTermDef name uni fun a
-> InlineM name uni fun a (Maybe (UTermDef name uni fun a))
processSingleBinding Term name uni fun a
t) [UTermDef name uni fun a]
bs
Term name uni fun a
t' <- Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm Term name uni fun a
t
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term name uni fun a
-> InlineM name uni fun a (Term name uni fun a))
-> Term name uni fun a
-> InlineM name uni fun a (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ [UTermDef name uni fun a]
-> Term name uni fun a -> Term name uni fun a
forall name (uni :: * -> *) fun a.
[UTermDef name uni fun a]
-> Term name uni fun a -> Term name uni fun a
restoreApps [UTermDef name uni fun a]
bs' Term name uni fun a
t'
Term name uni fun a
t -> Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
inlineSaturatedApp (Term name uni fun a
-> InlineM name uni fun a (Term name uni fun a))
-> InlineM name uni fun a (Term name uni fun a)
-> InlineM name uni fun a (Term name uni fun a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LensLike
(WrappedMonad
(ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))))
(Term name uni fun a)
(Term name uni fun a)
(Term name uni fun a)
(Term name uni fun a)
-> Term name uni fun a
-> (Term name uni fun a
-> InlineM name uni fun a (Term name uni fun a))
-> InlineM name uni fun a (Term name uni fun a)
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t
forMOf LensLike
(WrappedMonad
(ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))))
(Term name uni fun a)
(Term name uni fun a)
(Term name uni fun a)
(Term name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Applicative f =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> Term name uni fun ann -> f (Term name uni fun ann)
termSubterms Term name uni fun a
t Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm
substName :: name -> InlineM name uni fun a (Maybe (Term name uni fun a))
substName :: name
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (Term name uni fun a))
substName name
name = (S name uni fun a -> Maybe (InlineTerm name uni fun a))
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (InlineTerm name uni fun a))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (name -> S name uni fun a -> Maybe (InlineTerm name uni fun a)
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (InlineTerm name uni fun a)
lookupTerm name
name) ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (InlineTerm name uni fun a))
-> (Maybe (InlineTerm name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (Term name uni fun a)))
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (Term name uni fun a))
forall a b.
ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
-> (a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InlineTerm name uni fun a
-> InlineM name uni fun a (Term name uni fun a))
-> Maybe (InlineTerm name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (Term name uni fun a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse InlineTerm name uni fun a
-> InlineM name uni fun a (Term name uni fun a)
renameTerm
renameTerm :: InlineTerm name uni fun a -> InlineM name uni fun a (Term name uni fun a)
renameTerm :: InlineTerm name uni fun a
-> InlineM name uni fun a (Term name uni fun a)
renameTerm = \case
Done Dupable (Term name uni fun a)
t -> Dupable (Term name uni fun a)
-> InlineM name uni fun a (Term name uni fun a)
forall (m :: * -> *) a.
(MonadQuote m, Rename a) =>
Dupable a -> m a
liftDupable Dupable (Term name uni fun a)
t
processSingleBinding ::
(InliningConstraints name uni fun) =>
Term name uni fun a ->
UTermDef name uni fun a ->
InlineM name uni fun a (Maybe (UTermDef name uni fun a))
processSingleBinding :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> UTermDef name uni fun a
-> InlineM name uni fun a (Maybe (UTermDef name uni fun a))
processSingleBinding Term name uni fun a
body (Def vd :: UVarDecl name a
vd@(UVarDecl a
a name
n) Term name uni fun a
rhs0) = do
Term name uni fun a
-> a
-> name
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> a
-> name
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
maybeAddSubst Term name uni fun a
body a
a name
n Term name uni fun a
rhs0 InlineM name uni fun a (Maybe (Term name uni fun a))
-> (Maybe (Term name uni fun a)
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a))))
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a b.
ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
-> (a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Term name uni fun a
rhs -> do
let ([name]
binders, Term name uni fun a
rhsBody) = Term name uni fun a -> ([name], Term name uni fun a)
forall name (uni :: * -> *) fun a.
Term name uni fun a -> ([name], Term name uni fun a)
UPLC.splitParams Term name uni fun a
rhs
(S name uni fun a -> S name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((S name uni fun a -> S name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
())
-> (VarInfo name uni fun a -> S name uni fun a -> S name uni fun a)
-> VarInfo name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name
-> VarInfo name uni fun a -> S name uni fun a -> S name uni fun a
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> VarInfo name uni fun a -> S name uni fun a -> S name uni fun a
extendVarInfo name
n (VarInfo name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
())
-> VarInfo name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
()
forall a b. (a -> b) -> a -> b
$
VarInfo
{ _varBinders :: [name]
_varBinders = [name]
binders
, _varRhs :: Term name uni fun a
_varRhs = Term name uni fun a
rhs
, _varRhsBody :: InlineTerm name uni fun a
_varRhsBody = Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall name (uni :: * -> *) fun a.
Dupable (Term name uni fun a) -> InlineTerm name uni fun a
Done (Term name uni fun a -> Dupable (Term name uni fun a)
forall a. a -> Dupable a
dupable Term name uni fun a
rhsBody)
}
Maybe (Def (UVarDecl name a) (Term name uni fun a))
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Def (UVarDecl name a) (Term name uni fun a))
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a))))
-> (Def (UVarDecl name a) (Term name uni fun a)
-> Maybe (Def (UVarDecl name a) (Term name uni fun a)))
-> Def (UVarDecl name a) (Term name uni fun a)
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Def (UVarDecl name a) (Term name uni fun a)
-> Maybe (Def (UVarDecl name a) (Term name uni fun a))
forall a. a -> Maybe a
Just (Def (UVarDecl name a) (Term name uni fun a)
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a))))
-> Def (UVarDecl name a) (Term name uni fun a)
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a b. (a -> b) -> a -> b
$ UVarDecl name a
-> Term name uni fun a
-> Def (UVarDecl name a) (Term name uni fun a)
forall var val. var -> val -> Def var val
Def UVarDecl name a
vd Term name uni fun a
rhs
Maybe (Term name uni fun a)
Nothing -> Maybe (Def (UVarDecl name a) (Term name uni fun a))
-> InlineM
name
uni
fun
a
(Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Def (UVarDecl name a) (Term name uni fun a))
forall a. Maybe a
Nothing
maybeAddSubst ::
forall name uni fun a.
(InliningConstraints name uni fun) =>
Term name uni fun a ->
a ->
name ->
Term name uni fun a ->
InlineM name uni fun a (Maybe (Term name uni fun a))
maybeAddSubst :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> a
-> name
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
maybeAddSubst Term name uni fun a
body a
a name
n Term name uni fun a
rhs0 = do
Term name uni fun a
rhs <- Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm Term name uni fun a
rhs0
InlineHints name a
hints <- Getting
(InlineHints name a) (InlineInfo name fun a) (InlineHints name a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(InlineHints name a)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(InlineHints name a) (InlineInfo name fun a) (InlineHints name a)
forall name fun a name a (f :: * -> *).
Functor f =>
(InlineHints name a -> f (InlineHints name a))
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiHints
let hinted :: Bool
hinted = InlineHints name a -> a -> name -> Bool
forall name a. InlineHints name a -> a -> name -> Bool
shouldInline InlineHints name a
hints a
a name
n
if Bool
hinted
then InlineTerm name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall b.
InlineTerm name uni fun a -> InlineM name uni fun a (Maybe b)
extendAndDrop (Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall name (uni :: * -> *) fun a.
Dupable (Term name uni fun a) -> InlineTerm name uni fun a
Done (Dupable (Term name uni fun a) -> InlineTerm name uni fun a)
-> Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Dupable (Term name uni fun a)
forall a. a -> Dupable a
dupable Term name uni fun a
rhs)
else
ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
Bool
-> InlineM name uni fun a (Maybe (Term name uni fun a))
-> InlineM name uni fun a (Maybe (Term name uni fun a))
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
(name
-> Term name uni fun a
-> Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
shouldUnconditionallyInline name
n Term name uni fun a
rhs Term name uni fun a
body)
(InlineTerm name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall b.
InlineTerm name uni fun a -> InlineM name uni fun a (Maybe b)
extendAndDrop (Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall name (uni :: * -> *) fun a.
Dupable (Term name uni fun a) -> InlineTerm name uni fun a
Done (Dupable (Term name uni fun a) -> InlineTerm name uni fun a)
-> Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Dupable (Term name uni fun a)
forall a. a -> Dupable a
dupable Term name uni fun a
rhs))
(Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Maybe (Term name uni fun a)
forall a. a -> Maybe a
Just Term name uni fun a
rhs)
where
extendAndDrop ::
forall b.
InlineTerm name uni fun a ->
InlineM name uni fun a (Maybe b)
extendAndDrop :: forall b.
InlineTerm name uni fun a -> InlineM name uni fun a (Maybe b)
extendAndDrop InlineTerm name uni fun a
t = (S name uni fun a -> S name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (name
-> InlineTerm name uni fun a
-> S name uni fun a
-> S name uni fun a
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> InlineTerm name uni fun a
-> S name uni fun a
-> S name uni fun a
extendTerm name
n InlineTerm name uni fun a
t) ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
()
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe b)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe b)
forall a b.
ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe b
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe b)
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
shouldUnconditionallyInline ::
(InliningConstraints name uni fun) =>
name ->
Term name uni fun a ->
Term name uni fun a ->
InlineM name uni fun a Bool
shouldUnconditionallyInline :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
shouldUnconditionallyInline name
n Term name uni fun a
rhs Term name uni fun a
body = do
Bool
isTermPure <- Term name uni fun a -> InlineM name uni fun a Bool
forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
Term name uni fun a -> InlineM name uni fun a Bool
checkPurity Term name uni fun a
rhs
Bool
inlineConstants <- Getting Bool (InlineInfo name fun a) Bool
-> InlineM name uni fun a Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool (InlineInfo name fun a) Bool
forall name fun a (f :: * -> *).
Functor f =>
(Bool -> f Bool)
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiInlineConstants
Bool -> InlineM name uni fun a Bool
preUnconditional Bool
isTermPure InlineM name uni fun a Bool
-> InlineM name uni fun a Bool -> InlineM name uni fun a Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^ Bool -> Bool -> InlineM name uni fun a Bool
postUnconditional Bool
inlineConstants Bool
isTermPure
where
preUnconditional :: Bool -> InlineM name uni fun a Bool
preUnconditional Bool
isTermPure = name -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name -> InlineM name uni fun a Bool
nameUsedAtMostOnce name
n InlineM name uni fun a Bool
-> InlineM name uni fun a Bool -> InlineM name uni fun a Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Term name uni fun a -> name -> Bool -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> name -> Bool -> InlineM name uni fun a Bool
effectSafe Term name uni fun a
body name
n Bool
isTermPure
postUnconditional :: Bool -> Bool -> InlineM name uni fun a Bool
postUnconditional Bool
inlineConstants Bool
isTermPure =
Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isTermPure InlineM name uni fun a Bool
-> InlineM name uni fun a Bool -> InlineM name uni fun a Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Bool -> Term name uni fun a -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> InlineM name uni fun a Bool
acceptable Bool
inlineConstants Term name uni fun a
rhs
checkPurity :: PLC.ToBuiltinMeaning uni fun => Term name uni fun a -> InlineM name uni fun a Bool
checkPurity :: forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
Term name uni fun a -> InlineM name uni fun a Bool
checkPurity Term name uni fun a
t = do
BuiltinSemanticsVariant fun
builtinSemanticsVariant <- Getting
(BuiltinSemanticsVariant fun)
(InlineInfo name fun a)
(BuiltinSemanticsVariant fun)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(BuiltinSemanticsVariant fun)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(BuiltinSemanticsVariant fun)
(InlineInfo name fun a)
(BuiltinSemanticsVariant fun)
forall name fun a fun (f :: * -> *).
Functor f =>
(BuiltinSemanticsVariant fun -> f (BuiltinSemanticsVariant fun))
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiBuiltinSemanticsVariant
Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun a Bool)
-> Bool -> InlineM name uni fun a Bool
forall a b. (a -> b) -> a -> b
$ BuiltinSemanticsVariant fun -> Term name uni fun a -> Bool
forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
BuiltinSemanticsVariant fun -> Term name uni fun a -> Bool
isPure BuiltinSemanticsVariant fun
builtinSemanticsVariant Term name uni fun a
t
nameUsedAtMostOnce ::
forall name uni fun a.
(InliningConstraints name uni fun) =>
name ->
InlineM name uni fun a Bool
nameUsedAtMostOnce :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name -> InlineM name uni fun a Bool
nameUsedAtMostOnce name
n = do
Usages
usgs <- Getting Usages (InlineInfo name fun a) Usages
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
Usages
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Usages (InlineInfo name fun a) Usages
forall name fun a (f :: * -> *).
Functor f =>
(Usages -> f Usages)
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiUsages
Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun a Bool)
-> Bool -> InlineM name uni fun a Bool
forall a b. (a -> b) -> a -> b
$ name -> Usages -> Int
forall n unique. HasUnique n unique => n -> Usages -> Int
Usages.getUsageCount name
n Usages
usgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
isFirstVarBeforeEffects
:: forall name uni fun ann. InliningConstraints name uni fun
=> name
-> Term name uni fun ann
-> InlineM name uni fun ann Bool
isFirstVarBeforeEffects :: forall name (uni :: * -> *) fun ann.
InliningConstraints name uni fun =>
name -> Term name uni fun ann -> InlineM name uni fun ann Bool
isFirstVarBeforeEffects name
n Term name uni fun ann
t = do
BuiltinSemanticsVariant fun
builtinSemanticsVariant <- Getting
(BuiltinSemanticsVariant fun)
(InlineInfo name fun ann)
(BuiltinSemanticsVariant fun)
-> ReaderT
(InlineInfo name fun ann)
(StateT (S name uni fun ann) (QuoteT Identity))
(BuiltinSemanticsVariant fun)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(BuiltinSemanticsVariant fun)
(InlineInfo name fun ann)
(BuiltinSemanticsVariant fun)
forall name fun a fun (f :: * -> *).
Functor f =>
(BuiltinSemanticsVariant fun -> f (BuiltinSemanticsVariant fun))
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiBuiltinSemanticsVariant
Bool -> InlineM name uni fun ann Bool
forall a.
a
-> ReaderT
(InlineInfo name fun ann)
(StateT (S name uni fun ann) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun ann Bool)
-> Bool -> InlineM name uni fun ann Bool
forall a b. (a -> b) -> a -> b
$ [EvalTerm name uni fun ann] -> Bool
go (EvalOrder name uni fun ann -> [EvalTerm name uni fun ann]
forall name (uni :: * -> *) fun a.
EvalOrder name uni fun a -> [EvalTerm name uni fun a]
unEvalOrder (BuiltinSemanticsVariant fun
-> Term name uni fun ann -> EvalOrder name uni fun ann
forall name (uni :: * -> *) fun a.
ToBuiltinMeaning uni fun =>
BuiltinSemanticsVariant fun
-> Term name uni fun a -> EvalOrder name uni fun a
termEvaluationOrder BuiltinSemanticsVariant fun
builtinSemanticsVariant Term name uni fun ann
t))
where
go :: [EvalTerm name uni fun ann] -> Bool
go ((EvalTerm Purity
_ WorkFreedom
_ (Var ann
_ name
n')):[EvalTerm name uni fun ann]
_) | name
n name -> name -> Bool
forall a. Eq a => a -> a -> Bool
== name
n' = Bool
True
go ((EvalTerm Purity
Pure WorkFreedom
_ Term name uni fun ann
_):[EvalTerm name uni fun ann]
rest) = [EvalTerm name uni fun ann] -> Bool
go [EvalTerm name uni fun ann]
rest
go ((EvalTerm Purity
MaybeImpure WorkFreedom
_ Term name uni fun ann
_):[EvalTerm name uni fun ann]
_) = Bool
False
go (EvalTerm name uni fun ann
Unknown:[EvalTerm name uni fun ann]
_) = Bool
False
go [] = Bool
False
effectSafe ::
forall name uni fun a.
(InliningConstraints name uni fun) =>
Term name uni fun a ->
name ->
Bool ->
InlineM name uni fun a Bool
effectSafe :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> name -> Bool -> InlineM name uni fun a Bool
effectSafe Term name uni fun a
body name
n Bool
purity = do
Bool
immediatelyEvaluated <- name -> Term name uni fun a -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun ann.
InliningConstraints name uni fun =>
name -> Term name uni fun ann -> InlineM name uni fun ann Bool
isFirstVarBeforeEffects name
n Term name uni fun a
body
Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun a Bool)
-> Bool -> InlineM name uni fun a Bool
forall a b. (a -> b) -> a -> b
$ Bool
purity Bool -> Bool -> Bool
|| Bool
immediatelyEvaluated
acceptable ::
Bool ->
Term name uni fun a ->
InlineM name uni fun a Bool
acceptable :: forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> InlineM name uni fun a Bool
acceptable Bool
inlineConstants Term name uni fun a
t =
Bool
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
Bool
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
Bool)
-> Bool
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
Bool
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable Term name uni fun a
t Bool -> Bool -> Bool
&& Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
t
costIsAcceptable :: Term name uni fun a -> Bool
costIsAcceptable :: forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable = \case
Builtin{} -> Bool
True
Var{} -> Bool
True
Constant{} -> Bool
True
Error{} -> Bool
True
LamAbs{} -> Bool
True
Apply{} -> Bool
False
Constr a
_ Word64
_ [Term name uni fun a]
es -> case [Term name uni fun a]
es of
[] -> Bool
True
[Term name uni fun a
e] -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable Term name uni fun a
e
[Term name uni fun a]
_ -> Bool
False
Case{} -> Bool
False
Force{} -> Bool
False
Delay{} -> Bool
True
sizeIsAcceptable ::
Bool ->
Term name uni fun a ->
Bool
sizeIsAcceptable :: forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants = \case
Builtin{} -> Bool
True
Var{} -> Bool
True
Error{} -> Bool
True
LamAbs{} -> Bool
False
Constr a
_ Word64
_ [Term name uni fun a]
es -> case [Term name uni fun a]
es of
[] -> Bool
True
[Term name uni fun a
e] -> Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
e
[Term name uni fun a]
_ -> Bool
False
Case{} -> Bool
False
Constant{} -> Bool
inlineConstants
Apply{} -> Bool
False
Force a
_ Term name uni fun a
t -> Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
t
Delay a
_ Term name uni fun a
t -> Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
t
fullyApplyAndBetaReduce ::
forall name uni fun a.
(InliningConstraints name uni fun) =>
VarInfo name uni fun a ->
[(a, Term name uni fun a)] ->
InlineM name uni fun a (Maybe (Term name uni fun a))
fullyApplyAndBetaReduce :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
VarInfo name uni fun a
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
fullyApplyAndBetaReduce VarInfo name uni fun a
info [(a, Term name uni fun a)]
args0 = do
Term name uni fun a
rhsBody <- Dupable (Term name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall (m :: * -> *) a.
(MonadQuote m, Rename a) =>
Dupable a -> m a
liftDupable (let Done Dupable (Term name uni fun a)
rhsBody = VarInfo name uni fun a
info VarInfo name uni fun a
-> Getting
(InlineTerm name uni fun a)
(VarInfo name uni fun a)
(InlineTerm name uni fun a)
-> InlineTerm name uni fun a
forall s a. s -> Getting a s a -> a
^. Getting
(InlineTerm name uni fun a)
(VarInfo name uni fun a)
(InlineTerm name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Functor f =>
(InlineTerm name uni fun ann -> f (InlineTerm name uni fun ann))
-> VarInfo name uni fun ann -> f (VarInfo name uni fun ann)
varRhsBody in Dupable (Term name uni fun a)
rhsBody)
let go ::
Term name uni fun a ->
[name] ->
[(a, Term name uni fun a)] ->
InlineM name uni fun a (Maybe (Term name uni fun a))
go :: Term name uni fun a
-> [name]
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
go Term name uni fun a
acc [name]
bs [(a, Term name uni fun a)]
args = case ([name]
bs, [(a, Term name uni fun a)]
args) of
([], [(a, Term name uni fun a)]
_) -> Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> (Term name uni fun a -> Maybe (Term name uni fun a))
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term name uni fun a -> Maybe (Term name uni fun a)
forall a. a -> Maybe a
Just (Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a b. (a -> b) -> a -> b
$ Term name uni fun a
-> [(a, Term name uni fun a)] -> Term name uni fun a
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
mkIterApp Term name uni fun a
acc [(a, Term name uni fun a)]
args
(name
param : [name]
params, (a
_ann, Term name uni fun a
arg) : [(a, Term name uni fun a)]
args') -> do
Bool
safe <- name -> Term name uni fun a -> InlineM name uni fun a Bool
safeToBetaReduce name
param Term name uni fun a
arg
if Bool
safe
then do
Term name uni fun a
acc' <-
(name -> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall (m :: * -> *) name (uni :: * -> *) fun ann.
Monad m =>
(name -> m (Maybe (Term name uni fun ann)))
-> Term name uni fun ann -> m (Term name uni fun ann)
termSubstNamesM
(\name
n -> if name
n name -> name -> Bool
forall a. Eq a => a -> a -> Bool
== name
param then Term name uni fun a -> Maybe (Term name uni fun a)
forall a. a -> Maybe a
Just (Term name uni fun a -> Maybe (Term name uni fun a))
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a (m :: * -> *). (Rename a, MonadQuote m) => a -> m a
forall (m :: * -> *).
MonadQuote m =>
Term name uni fun a -> m (Term name uni fun a)
PLC.rename Term name uni fun a
arg else Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term name uni fun a)
forall a. Maybe a
Nothing)
Term name uni fun a
acc
Term name uni fun a
-> [name]
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
go Term name uni fun a
acc' [name]
params [(a, Term name uni fun a)]
args'
else Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term name uni fun a)
forall a. Maybe a
Nothing
([name], [(a, Term name uni fun a)])
_ -> Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term name uni fun a)
forall a. Maybe a
Nothing
safeToBetaReduce ::
name ->
Term name uni fun a ->
InlineM name uni fun a Bool
safeToBetaReduce :: name -> Term name uni fun a -> InlineM name uni fun a Bool
safeToBetaReduce name
a Term name uni fun a
arg = name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
shouldUnconditionallyInline name
a Term name uni fun a
arg Term name uni fun a
rhsBody
Term name uni fun a
-> [name]
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
go Term name uni fun a
rhsBody (VarInfo name uni fun a
info VarInfo name uni fun a
-> Getting [name] (VarInfo name uni fun a) [name] -> [name]
forall s a. s -> Getting a s a -> a
^. Getting [name] (VarInfo name uni fun a) [name]
forall name (uni :: * -> *) fun ann (f :: * -> *).
Functor f =>
([name] -> f [name])
-> VarInfo name uni fun ann -> f (VarInfo name uni fun ann)
varBinders) [(a, Term name uni fun a)]
args0
inlineSaturatedApp ::
forall name uni fun a.
(InliningConstraints name uni fun) =>
Term name uni fun a ->
InlineM name uni fun a (Term name uni fun a)
inlineSaturatedApp :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
inlineSaturatedApp Term name uni fun a
t
| (Var a
_ann name
name, [(a, Term name uni fun a)]
args) <- Term name uni fun a
-> (Term name uni fun a, [(a, Term name uni fun a)])
forall name (uni :: * -> *) fun a.
Term name uni fun a
-> (Term name uni fun a, [(a, Term name uni fun a)])
UPLC.splitApplication Term name uni fun a
t =
(S name uni fun a -> Maybe (VarInfo name uni fun a))
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (VarInfo name uni fun a))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (name -> S name uni fun a -> Maybe (VarInfo name uni fun a)
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (VarInfo name uni fun a)
lookupVarInfo name
name) ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Maybe (VarInfo name uni fun a))
-> (Maybe (VarInfo name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a))
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a b.
ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
-> (a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (VarInfo name uni fun a)
Nothing -> Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term name uni fun a
t
Just VarInfo name uni fun a
varInfo ->
VarInfo name uni fun a
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
VarInfo name uni fun a
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
fullyApplyAndBetaReduce VarInfo name uni fun a
varInfo [(a, Term name uni fun a)]
args InlineM name uni fun a (Maybe (Term name uni fun a))
-> (Maybe (Term name uni fun a)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a))
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a b.
ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
-> (a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b)
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Term name uni fun a)
Nothing -> Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term name uni fun a
t
Just Term name uni fun a
fullyApplied -> do
let
sizeIsOk :: Bool
sizeIsOk = Term name uni fun a -> Size
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> Size
termSize Term name uni fun a
fullyApplied Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Term name uni fun a -> Size
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> Size
termSize Term name uni fun a
t
rhs :: Term name uni fun a
rhs = VarInfo name uni fun a
varInfo VarInfo name uni fun a
-> Getting
(Term name uni fun a)
(VarInfo name uni fun a)
(Term name uni fun a)
-> Term name uni fun a
forall s a. s -> Getting a s a -> a
^. Getting
(Term name uni fun a)
(VarInfo name uni fun a)
(Term name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Functor f =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> VarInfo name uni fun ann -> f (VarInfo name uni fun ann)
varRhs
costIsOk :: Bool
costIsOk = Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable Term name uni fun a
rhs
Bool
rhsPure <- Term name uni fun a -> InlineM name uni fun a Bool
forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
Term name uni fun a -> InlineM name uni fun a Bool
checkPurity Term name uni fun a
rhs
Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a))
-> Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ if Bool
sizeIsOk Bool -> Bool -> Bool
&& Bool
costIsOk Bool -> Bool -> Bool
&& Bool
rhsPure then Term name uni fun a
fullyApplied else Term name uni fun a
t
| Bool
otherwise = Term name uni fun a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
(Term name uni fun a)
forall a.
a
-> ReaderT
(InlineInfo name fun a)
(StateT (S name uni fun a) (QuoteT Identity))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term name uni fun a
t