{-# LANGUAGE TemplateHaskell #-}
module UntypedPlutusCore.Simplify ( simplifyTerm, simplifyProgram, SimplifyOpts (..), soMaxSimplifierIterations, soInlineHints, defaultSimplifyOpts, InlineHints (..) ) where

import UntypedPlutusCore.Core.Type
import UntypedPlutusCore.Transform.ForceDelay
import UntypedPlutusCore.Transform.Inline

import Control.Monad
import Data.List
import PlutusCore.Builtin qualified as PLC
import PlutusCore.Name
import PlutusCore.Quote

import Control.Lens.TH

data SimplifyOpts a = SimplifyOpts { SimplifyOpts a -> Int
_soMaxSimplifierIterations  :: Int, SimplifyOpts a -> InlineHints Name a
_soInlineHints :: InlineHints Name a }
  deriving stock (Int -> SimplifyOpts a -> ShowS
[SimplifyOpts a] -> ShowS
SimplifyOpts a -> String
(Int -> SimplifyOpts a -> ShowS)
-> (SimplifyOpts a -> String)
-> ([SimplifyOpts a] -> ShowS)
-> Show (SimplifyOpts a)
forall a. Int -> SimplifyOpts a -> ShowS
forall a. [SimplifyOpts a] -> ShowS
forall a. SimplifyOpts a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimplifyOpts a] -> ShowS
$cshowList :: forall a. [SimplifyOpts a] -> ShowS
show :: SimplifyOpts a -> String
$cshow :: forall a. SimplifyOpts a -> String
showsPrec :: Int -> SimplifyOpts a -> ShowS
$cshowsPrec :: forall a. Int -> SimplifyOpts a -> ShowS
Show)

makeLenses ''SimplifyOpts

defaultSimplifyOpts :: SimplifyOpts a
defaultSimplifyOpts :: SimplifyOpts a
defaultSimplifyOpts = SimplifyOpts :: forall a. Int -> InlineHints Name a -> SimplifyOpts a
SimplifyOpts
    { _soMaxSimplifierIterations :: Int
_soMaxSimplifierIterations = Int
12
    , _soInlineHints :: InlineHints Name a
_soInlineHints = InlineHints Name a
forall a. Monoid a => a
mempty
    }

simplifyProgram
    :: forall uni fun m a
    . (PLC.ToBuiltinMeaning uni fun, MonadQuote m)
    => SimplifyOpts a
    -> Program Name uni fun a
    -> m (Program Name uni fun a)
simplifyProgram :: SimplifyOpts a
-> Program Name uni fun a -> m (Program Name uni fun a)
simplifyProgram SimplifyOpts a
opts (Program a
a Version a
v Term Name uni fun a
t) = a -> Version a -> Term Name uni fun a -> Program Name uni fun a
forall name (uni :: * -> *) fun ann.
ann
-> Version ann -> Term name uni fun ann -> Program name uni fun ann
Program a
a Version a
v (Term Name uni fun a -> Program Name uni fun a)
-> m (Term Name uni fun a) -> m (Program Name uni fun a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimplifyOpts a -> Term Name uni fun a -> m (Term Name uni fun a)
forall (uni :: * -> *) fun (m :: * -> *) a.
(ToBuiltinMeaning uni fun, MonadQuote m) =>
SimplifyOpts a -> Term Name uni fun a -> m (Term Name uni fun a)
simplifyTerm SimplifyOpts a
opts Term Name uni fun a
t

simplifyTerm
    :: forall uni fun m a
    . (PLC.ToBuiltinMeaning uni fun, MonadQuote m)
    => SimplifyOpts a
    -> Term Name uni fun a
    -> m (Term Name uni fun a)
simplifyTerm :: SimplifyOpts a -> Term Name uni fun a -> m (Term Name uni fun a)
simplifyTerm SimplifyOpts a
opts = Int -> Term Name uni fun a -> m (Term Name uni fun a)
simplifyNTimes (SimplifyOpts a -> Int
forall a. SimplifyOpts a -> Int
_soMaxSimplifierIterations SimplifyOpts a
opts)
    where
        -- Run the simplifier @n@ times
        simplifyNTimes :: Int -> Term Name uni fun a -> m (Term Name uni fun a)
        simplifyNTimes :: Int -> Term Name uni fun a -> m (Term Name uni fun a)
simplifyNTimes Int
n = ((Term Name uni fun a -> m (Term Name uni fun a))
 -> (Term Name uni fun a -> m (Term Name uni fun a))
 -> Term Name uni fun a
 -> m (Term Name uni fun a))
-> (Term Name uni fun a -> m (Term Name uni fun a))
-> [Term Name uni fun a -> m (Term Name uni fun a)]
-> Term Name uni fun a
-> m (Term Name uni fun a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Term Name uni fun a -> m (Term Name uni fun a))
-> (Term Name uni fun a -> m (Term Name uni fun a))
-> Term Name uni fun a
-> m (Term Name uni fun a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
(>=>) Term Name uni fun a -> m (Term Name uni fun a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int -> Term Name uni fun a -> m (Term Name uni fun a))
-> [Int] -> [Term Name uni fun a -> m (Term Name uni fun a)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Term Name uni fun a -> m (Term Name uni fun a)
simplifyStep [Int
1 .. Int
n])
        -- generate simplification step
        simplifyStep :: Int -> Term Name uni fun a -> m (Term Name uni fun a)
        simplifyStep :: Int -> Term Name uni fun a -> m (Term Name uni fun a)
simplifyStep Int
_ Term Name uni fun a
term = InlineHints Name a
-> Term Name uni fun a -> m (Term Name uni fun a)
forall name (uni :: * -> *) fun (m :: * -> *) a.
ExternalConstraints name uni fun m =>
InlineHints name a
-> Term name uni fun a -> m (Term name uni fun a)
inline (SimplifyOpts a -> InlineHints Name a
forall a. SimplifyOpts a -> InlineHints Name a
_soInlineHints SimplifyOpts a
opts) (Term Name uni fun a -> Term Name uni fun a
forall name (uni :: * -> *) fun a.
Term name uni fun a -> Term name uni fun a
forceDelayCancel Term Name uni fun a
term)