{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskellQuotes      #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE ViewPatterns               #-}

-- Due to CPP
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
-- For some reason this module is very slow to compile otherwise
{-# OPTIONS_GHC -O0 #-}
module PlutusTx.Plugin (plugin, plc) where

import Data.Bifunctor
import PlutusPrelude
import PlutusTx.Bool ((&&), (||))
import PlutusTx.Builtins (mkNilOpaque, useFromOpaque, useToOpaque)
import PlutusTx.Code
import PlutusTx.Compiler.Builtins
import PlutusTx.Compiler.Error
import PlutusTx.Compiler.Expr
import PlutusTx.Compiler.Trace
import PlutusTx.Compiler.Types
import PlutusTx.Compiler.Utils
import PlutusTx.Coverage
import PlutusTx.PIRTypes
import PlutusTx.PLCTypes
import PlutusTx.Plugin.Utils
import PlutusTx.Trace

import GHC.ByteCode.Types qualified as GHC
import GHC.Core.Coercion.Opt qualified as GHC
import GHC.Core.FamInstEnv qualified as GHC
import GHC.Core.Opt.Arity qualified as GHC
import GHC.Core.Opt.OccurAnal qualified as GHC
import GHC.Core.Opt.Simplify qualified as GHC
import GHC.Core.Opt.Simplify.Env qualified as GHC
import GHC.Core.Opt.Simplify.Monad qualified as GHC
#if MIN_VERSION_ghc(9,6,0)
import GHC.Core.Rules.Config qualified as GHC
#endif
import GHC.Core.Unfold qualified as GHC
import GHC.Plugins qualified as GHC
import GHC.Types.TyThing qualified as GHC
import GHC.Utils.Logger qualified as GHC

import PlutusCore qualified as PLC
import PlutusCore.Builtin qualified as PLC
import PlutusCore.Compiler qualified as PLC
import PlutusCore.Pretty as PLC
import PlutusCore.Quote
import PlutusCore.Version qualified as PLC

import UntypedPlutusCore qualified as UPLC

import PlutusIR qualified as PIR
import PlutusIR.Compiler qualified as PIR
import PlutusIR.Compiler.Definitions qualified as PIR
import PlutusTx.Options

import Language.Haskell.TH.Syntax as TH hiding (lift)

import Control.Exception (throwIO)
import Control.Lens
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Flat (Flat, flat, unflat)

import Data.ByteString qualified as BS
import Data.ByteString.Unsafe qualified as BSUnsafe
import Data.Either.Validation
import Data.Map qualified as Map
import Data.Monoid.Extra (mwhen)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Type.Bool qualified as PlutusTx.Bool
import GHC.Num.Integer qualified
import PlutusCore.Default (DefaultFun, DefaultUni)
import PlutusIR.Analysis.Builtins
import PlutusIR.Compiler.Provenance (noProvenance, original)
import PlutusIR.Compiler.Types qualified as PIR
import PlutusIR.Transform.RewriteRules
import PlutusIR.Transform.RewriteRules.RemoveTrace (rewriteRuleRemoveTrace)
import Prettyprinter qualified as PP
import System.IO (openBinaryTempFile)
import System.IO.Unsafe (unsafePerformIO)

data PluginCtx = PluginCtx
    { PluginCtx -> PluginOptions
pcOpts            :: PluginOptions
    , PluginCtx -> FamInstEnvs
pcFamEnvs         :: GHC.FamInstEnvs
    , PluginCtx -> Name
pcMarkerName      :: GHC.Name
    , PluginCtx -> ModuleName
pcModuleName      :: GHC.ModuleName
    , PluginCtx -> Maybe ModBreaks
pcModuleModBreaks :: Maybe GHC.ModBreaks
    }

{- Note [Making sure unfoldings are present]
Our plugin runs at the start of the Core pipeline. If we look around us, we will find
that as expected, we have unfoldings for some bindings from other modules or packages
depending on whether GHC thinks they're good to inline/are marked INLINEABLE.

But there will be no unfoldings for local bindings!

It turns out that these are added by the simplifier, of all things. To avoid relying too
much on the shape of the subsequent passes, we add a single, very gentle, simplifier
pass before we run, turning off everything that we can and running only once.

This means that we need to be robust to the transformations that the simplifier performs
unconditionally which we pretty much are.

See https://gitlab.haskell.org/ghc/ghc/issues/16615 for upstream discussion.
-}

{- Note [newtype field accessors in `base`]
For some unknown reason, newtype field accessors in `base`, such as `getFirst`, `appEndo` and
`getDual`, cause Cabal build and Nix build to behave differently. In Cabal build, these
field accessors' unfoldings are available to the GHC simplifier, and so the simplifier inlines
them into `Coercion`s. But in Nix build, somehow their unfoldings aren't available.

This started to happen after a seemingly innocent PR (#4552), and it eventually led to different
PIRs, PLCs and UPLCs, causing test failures. Replacing them with `coerce` avoids the problem.
-}

plugin :: GHC.Plugin
plugin :: Plugin
plugin = Plugin
GHC.defaultPlugin { GHC.pluginRecompile = GHC.flagRecompile
                           , GHC.installCoreToDos = install
                           }
    where
      install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo]
      install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install [CommandLineOption]
args [CoreToDo]
rest = do
          -- create simplifier pass to be placed at the front
          CoreToDo
simplPass <- DynFlags -> Logger -> CoreToDo
mkSimplPass (DynFlags -> Logger -> CoreToDo)
-> CoreM DynFlags -> CoreM (Logger -> CoreToDo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags CoreM (Logger -> CoreToDo) -> CoreM Logger -> CoreM CoreToDo
forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
GHC.getLogger
          -- instantiate our plugin pass
          CoreToDo
pluginPass <- PluginOptions -> CoreToDo
mkPluginPass (PluginOptions -> CoreToDo)
-> CoreM PluginOptions -> CoreM CoreToDo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [CommandLineOption] -> Validation ParseErrors PluginOptions
parsePluginOptions [CommandLineOption]
args of
              Success PluginOptions
opts -> PluginOptions -> CoreM PluginOptions
forall a. a -> CoreM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PluginOptions
opts
              Failure ParseErrors
errs -> IO PluginOptions -> CoreM PluginOptions
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PluginOptions -> CoreM PluginOptions)
-> IO PluginOptions -> CoreM PluginOptions
forall a b. (a -> b) -> a -> b
$ ParseErrors -> IO PluginOptions
forall e a. Exception e => e -> IO a
throwIO ParseErrors
errs
          -- return the pipeline
          [CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreToDo] -> CoreM [CoreToDo]) -> [CoreToDo] -> CoreM [CoreToDo]
forall a b. (a -> b) -> a -> b
$
             CoreToDo
simplPass
             CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: CoreToDo
pluginPass
             CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo]
rest

{- Note [GHC.sm_pre_inline]
We run a GHC simplifier pass before the plugin, in which we turn on `sm_pre_inline`, which
makes GHC inline certain bindings before the plugin runs. Pre-inlining is a phase of the GHC
inliner that inlines bindings in GHC Core where the binder occurs exactly once in an
unconditionally safe way (e.g., the occurrence isn't inside a lambda). For details, see paper
"Secrets of the Glasgow Haskell Compiler inliner".

The reason we need the pre-inlining is that the plugin requires certain functions
to be fully applied. For example, it has a special rule to handle
`noinline @(String -> BuiltinString) stringToBuiltinString "a"`, but it cannot compile
`let f = noinline @(String -> BuiltinString) stringToBuiltinString in f "a"`.
By turning on pre-inlining, the `f` in the latter expression will be inlined, resulting in
the former expression, which the plugin knows how to compile.

There is a related flag, `sm_inline`, which controls whether GHC's call-site inlining is
enabled. If enabled, GHC will inline additional bindings that cannot be unconditionally
inlined, on a call-site-by-call-site basis. Currently we haven't found the need to turn on
`sm_inline`. Turning it on seems to reduce PIR sizes in many cases, but it is unclear
whether it may affect the semantics of Plutus Core.

Arguably, relying on `sm_pre_inline` is not the proper solution - what if we get
`let f = noinline @(String -> BuiltinString) stringToBuiltinString in f "a" <> f "b"`?
Here `f` won't be pre-inlined because it occurs twice. Instead, we should perhaps
inline a binding when the RHS is a partially applied function that we need fully applied.
But so far we haven't had an issue like this.

We should also make the error message better in cases like this. The current error message is
"Unsupported feature: Type constructor: GHC.Prim.Char#", resulting from attempting to inline
and compile `stringToBuiltinString`.

Note also, this `sm_pre_inline` pass doesn't include some of the inlining GHC does before the
plugin.
The GHC desugarer generates a large number of intermediate definitions and general clutter that
should be removed quickly. So GHC's "simple optimiser" (GHC.Core.SimpleOpt) also inlines things with
single occurrences. This is why the OPAQUE pragma is needed to avoid inlining of bindings that
have single occurrence.
None of -fmax-simplifier-iterations=0  -fforce-recomp -O0 would prevent it,
nor will turning off `sm_pre_inline`.
See https://gitlab.haskell.org/ghc/ghc/-/issues/23337.
-}

-- | A simplifier pass, implemented by GHC
mkSimplPass :: GHC.DynFlags -> GHC.Logger -> GHC.CoreToDo
mkSimplPass :: DynFlags -> Logger -> CoreToDo
mkSimplPass DynFlags
dflags Logger
logger =
  -- See Note [Making sure unfoldings are present]
#if MIN_VERSION_ghc(9,6,0)
  -- Changed in 9.6
  SimplifyOpts -> CoreToDo
GHC.CoreDoSimplify (SimplifyOpts -> CoreToDo) -> SimplifyOpts -> CoreToDo
forall a b. (a -> b) -> a -> b
$ GHC.SimplifyOpts
    { so_dump_core_sizes :: Bool
GHC.so_dump_core_sizes = Bool
False
    , so_iterations :: Int
GHC.so_iterations = Int
1
    , so_mode :: SimplMode
GHC.so_mode = SimplMode
simplMode
    , so_pass_result_cfg :: Maybe LintPassResultConfig
GHC.so_pass_result_cfg = Maybe LintPassResultConfig
forall a. Maybe a
Nothing
    , so_hpt_rules :: RuleBase
GHC.so_hpt_rules = RuleBase
GHC.emptyRuleBase
    , so_top_env_cfg :: TopEnvConfig
GHC.so_top_env_cfg = Int -> Int -> TopEnvConfig
GHC.TopEnvConfig Int
0 Int
0
    }
#else
  GHC.CoreDoSimplify 1 simplMode
#endif
    where
      simplMode :: SimplMode
simplMode = GHC.SimplMode
        { sm_names :: [CommandLineOption]
GHC.sm_names = [CommandLineOption
"Ensure unfoldings are present"]
        , sm_phase :: CompilerPhase
GHC.sm_phase = CompilerPhase
GHC.InitialPhase
        , sm_uf_opts :: UnfoldingOpts
GHC.sm_uf_opts = UnfoldingOpts
GHC.defaultUnfoldingOpts
        , sm_rules :: Bool
GHC.sm_rules = Bool
False
        , sm_cast_swizzle :: Bool
GHC.sm_cast_swizzle = Bool
True
        -- See Note [GHC.sm_pre_inline]
        , sm_pre_inline :: Bool
GHC.sm_pre_inline = Bool
True
        -- You might think you would need this, but apparently not
        , sm_inline :: Bool
GHC.sm_inline = Bool
False
        , sm_case_case :: Bool
GHC.sm_case_case = Bool
False
        , sm_eta_expand :: Bool
GHC.sm_eta_expand = Bool
False
#if MIN_VERSION_ghc(9,6,0)
        , sm_float_enable :: FloatEnable
GHC.sm_float_enable = FloatEnable
GHC.FloatDisabled
        , sm_do_eta_reduction :: Bool
GHC.sm_do_eta_reduction = Bool
False
        , sm_arity_opts :: ArityOpts
GHC.sm_arity_opts = Bool -> Bool -> ArityOpts
GHC.ArityOpts Bool
False Bool
False
        , sm_rule_opts :: RuleOpts
GHC.sm_rule_opts = Platform -> Bool -> Bool -> Bool -> RuleOpts
GHC.RuleOpts (DynFlags -> Platform
GHC.targetPlatform DynFlags
dflags) Bool
False Bool
True Bool
False
        , sm_case_folding :: Bool
GHC.sm_case_folding = Bool
False
        , sm_case_merge :: Bool
GHC.sm_case_merge = Bool
False
        , sm_co_opt_opts :: OptCoercionOpts
GHC.sm_co_opt_opts = Bool -> OptCoercionOpts
GHC.OptCoercionOpts Bool
False
#else
        , GHC.sm_logger = logger
        , GHC.sm_dflags = dflags
#endif
        }

{- Note [Marker resolution]
We use TH's 'foo exact syntax for resolving the 'plc marker's ghc name, as
explained in: <http://hackage.haskell.org/package/ghc-8.10.1/docs/GhcPlugins.html#v:thNameToGhcName>

The GHC haddock suggests that the "exact syntax" will always succeed because it is statically
resolved here (inside this Plugin module);

If this is the case, then it means that our plugin will always traverse each module's binds
searching for plc markers even in the case that the `plc` name is not in scope locally in the module
 under compilation.

The alternative is to use the "dynamic syntax" (`TH.mkName "plc"`), which implies that
the "plc" name will be resolved dynamically during module's compilation. In case "plc" is not
locally in scope,
the plugin would finish faster by completely skipping the module under compilation.
This dynamic approach comes with its own downsides however,
because the user may have imported "plc" qualified or aliased it, which will fail to resolve.
-}


-- | Our plugin works at haskell-module level granularity; the plugin
-- looks at the module's top-level bindings for plc markers and compiles their right-hand-side core
-- expressions.
mkPluginPass :: PluginOptions -> GHC.CoreToDo
mkPluginPass :: PluginOptions -> CoreToDo
mkPluginPass PluginOptions
opts = CommandLineOption -> CorePluginPass -> CoreToDo
GHC.CoreDoPluginPass CommandLineOption
"Core to PLC" (CorePluginPass -> CoreToDo) -> CorePluginPass -> CoreToDo
forall a b. (a -> b) -> a -> b
$ \ ModGuts
guts -> do
    -- Family env code borrowed from SimplCore
    PackageFamInstEnv
p_fam_env <- CoreM PackageFamInstEnv
GHC.getPackageFamInstEnv
    -- See Note [Marker resolution]
    Maybe Name
maybeMarkerName <- Name -> CoreM (Maybe Name)
GHC.thNameToGhcName 'plc
    case Maybe Name
maybeMarkerName of
        -- TODO: test that this branch can happen using TH's 'plc exact syntax.
        -- See Note [Marker resolution]
        Maybe Name
Nothing -> CorePluginPass
forall a. a -> CoreM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModGuts
guts
        Just Name
markerName ->
            let pctx :: PluginCtx
pctx = PluginCtx { pcOpts :: PluginOptions
pcOpts = PluginOptions
opts
                                 , pcFamEnvs :: FamInstEnvs
pcFamEnvs = (PackageFamInstEnv
p_fam_env, ModGuts -> PackageFamInstEnv
GHC.mg_fam_inst_env ModGuts
guts)
                                 , pcMarkerName :: Name
pcMarkerName = Name
markerName
                                 , pcModuleName :: ModuleName
pcModuleName = GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModGuts -> GenModule Unit
GHC.mg_module ModGuts
guts
                                 , pcModuleModBreaks :: Maybe ModBreaks
pcModuleModBreaks = ModGuts -> Maybe ModBreaks
GHC.mg_modBreaks ModGuts
guts
                                 }
                -- start looking for plc calls from the top-level binds
            in (CoreProgram -> CoreM CoreProgram) -> CorePluginPass
GHC.bindsOnlyPass (PluginCtx
-> PluginM DefaultUni DefaultFun CoreProgram -> CoreM CoreProgram
forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun) =>
PluginCtx -> PluginM uni fun a -> CoreM a
runPluginM PluginCtx
pctx (PluginM DefaultUni DefaultFun CoreProgram -> CoreM CoreProgram)
-> (CoreProgram -> PluginM DefaultUni DefaultFun CoreProgram)
-> CoreProgram
-> CoreM CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBind
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreBind)
-> CoreProgram -> PluginM DefaultUni DefaultFun CoreProgram
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) -> [a] -> f [b]
traverse CoreBind
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
compileBind) ModGuts
guts

-- | The monad where the plugin runs in for each module.
-- It is a core->core compiler monad, called PluginM, augmented with pure errors.
type PluginM uni fun = ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) GHC.CoreM)

-- | Runs the plugin monad in a given context; throws a Ghc.Exception when compilation fails.
runPluginM
    :: (PLC.PrettyUni uni, PP.Pretty fun)
    => PluginCtx -> PluginM uni fun a -> GHC.CoreM a
runPluginM :: forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun) =>
PluginCtx -> PluginM uni fun a -> CoreM a
runPluginM PluginCtx
pctx PluginM uni fun a
act = do
    Either (CompileError uni fun Ann) a
res <- ExceptT (CompileError uni fun Ann) CoreM a
-> CoreM (Either (CompileError uni fun Ann) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (CompileError uni fun Ann) CoreM a
 -> CoreM (Either (CompileError uni fun Ann) a))
-> ExceptT (CompileError uni fun Ann) CoreM a
-> CoreM (Either (CompileError uni fun Ann) a)
forall a b. (a -> b) -> a -> b
$ PluginM uni fun a
-> PluginCtx -> ExceptT (CompileError uni fun Ann) CoreM a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT PluginM uni fun a
act PluginCtx
pctx
    case Either (CompileError uni fun Ann) a
res of
        Right a
x -> a -> CoreM a
forall a. a -> CoreM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        Left CompileError uni fun Ann
err ->
            let errInGhc :: GhcException
errInGhc = CommandLineOption -> GhcException
GHC.ProgramError (CommandLineOption -> GhcException)
-> (Doc Any -> CommandLineOption) -> Doc Any -> GhcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (Doc Any -> GhcException) -> Doc Any -> GhcException
forall a b. (a -> b) -> a -> b
$ Doc Any
"GHC Core to PLC plugin:" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> CompileError uni fun Ann -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. CompileError uni fun Ann -> Doc ann
PP.pretty CompileError uni fun Ann
err
            in IO a -> CoreM a
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> CoreM a) -> IO a -> CoreM a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall a. GhcException -> IO a
GHC.throwGhcExceptionIO GhcException
errInGhc

-- | Compiles all the marked expressions in the given binder into PLC literals.
compileBind :: GHC.CoreBind -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreBind
compileBind :: CoreBind
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
compileBind = \case
    GHC.NonRec Var
b CoreExpr
rhs -> Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
GHC.NonRec Var
b (CoreExpr -> CoreBind)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
rhs
    GHC.Rec [(Var, CoreExpr)]
bindsRhses -> [(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
GHC.Rec ([(Var, CoreExpr)] -> CoreBind)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [(Var, CoreExpr)]
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Var, CoreExpr)]
-> ((Var, CoreExpr)
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
         (Var, CoreExpr))
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [(Var, CoreExpr)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Var, CoreExpr)]
bindsRhses (((Var, CoreExpr)
  -> ReaderT
       PluginCtx
       (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
       (Var, CoreExpr))
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      [(Var, CoreExpr)])
-> ((Var, CoreExpr)
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
         (Var, CoreExpr))
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [(Var, CoreExpr)]
forall a b. (a -> b) -> a -> b
$ \(Var
b, CoreExpr
rhs) -> do
                                             CoreExpr
rhs' <- CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
rhs
                                             (Var, CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Var, CoreExpr)
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
b, CoreExpr
rhs'))

{- Note [Hooking in the plugin]
Working out what to process and where to put it is tricky. We are going to turn the result in
to a 'CompiledCode', not the Haskell expression we started with!

Currently we look for calls to the @plc :: a -> CompiledCode a@ function,
and we replace the whole application with the generated code object, which will still be well-typed.
-}

{- Note [Polymorphic values and Any]
If you try and use the plugin on a polymorphic expression, then GHC will replace the quantified
types with 'Any' and remove the type lambdas. This is pretty annoying, and I don't entirely
understand why it happens, despite poking around in GHC a fair bit.

Possibly it has to do with the type that is given to 'plc' being unconstrained, resulting in GHC
putting 'Any' there, and that then propagating into the type of the quote. It's tricky to experiment
with this, since you can't really specify a polymorphic type in a type application or in the
resulting 'CompiledCode' because that's impredicative polymorphism.
-}

-- | Compiles all the core-expressions surrounded by plc in the given expression into PLC literals.
compileMarkedExprs :: GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr
compileMarkedExprs :: CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
expr = do
    Name
markerName <- (PluginCtx -> Name)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Name
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> Name
pcMarkerName
    case CoreExpr
expr of
      GHC.App (GHC.App (GHC.App (GHC.App
                          -- function id
                          -- sometimes GHCi sticks ticks around this for some reason
                          (CoreExpr -> CoreExpr
stripTicks -> (GHC.Var Var
fid))
                          -- first type argument, must be a string literal type
                          (GHC.Type (Type -> Maybe FastString
GHC.isStrLitTy -> Just FastString
fs_locStr)))
                     -- second type argument
                     (GHC.Type Type
codeTy))
            CoreExpr
_)
            -- value argument
            CoreExpr
inner
          | Name
markerName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Var -> Name
GHC.idName Var
fid -> CommandLineOption
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprOrDefer (FastString -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show FastString
fs_locStr) Type
codeTy CoreExpr
inner
      e :: CoreExpr
e@(GHC.Var Var
fid) | Name
markerName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Var -> Name
GHC.idName Var
fid ->
        CompileError DefaultUni DefaultFun Ann
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
CompileError DefaultUni DefaultFun Ann
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError DefaultUni DefaultFun Ann
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> (SDoc -> CompileError DefaultUni DefaultFun Ann)
-> SDoc
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall c e. e -> WithContext c e
NoContext (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> (SDoc -> Error DefaultUni DefaultFun Ann)
-> SDoc
-> CompileError DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a. CommandLineOption -> Error uni fun a
InvalidMarkerError (CommandLineOption -> Error DefaultUni DefaultFun Ann)
-> (SDoc -> CommandLineOption)
-> SDoc
-> Error DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> CommandLineOption
GHC.showSDocUnsafe (SDoc
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> SDoc
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
e
      GHC.App CoreExpr
e CoreExpr
a -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
GHC.App (CoreExpr -> CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  (CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b.
ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  (a -> b)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
a
      GHC.Lam Var
b CoreExpr
e -> Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
GHC.Lam Var
b (CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e
      GHC.Let CoreBind
bnd CoreExpr
e -> CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
GHC.Let (CoreBind -> CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBind
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
compileBind CoreBind
bnd ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  (CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b.
ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  (a -> b)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e
      GHC.Case CoreExpr
e Var
b Type
t [Alt Var]
alts -> do
            CoreExpr
e' <- CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e
            let expAlt :: Alt Var
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Alt Var)
expAlt (GHC.Alt AltCon
a [Var]
bs CoreExpr
rhs) = AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
GHC.Alt AltCon
a [Var]
bs (CoreExpr -> Alt Var)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Alt Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
rhs
            [Alt Var]
alts' <- (Alt Var
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      (Alt Var))
-> [Alt Var]
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [Alt Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Alt Var
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Alt Var)
expAlt [Alt Var]
alts
            CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
GHC.Case CoreExpr
e' Var
b Type
t [Alt Var]
alts'
      GHC.Cast CoreExpr
e CoercionR
c -> (CoreExpr -> CoercionR -> CoreExpr)
-> CoercionR -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
GHC.Cast CoercionR
c (CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e
      GHC.Tick CoreTickish
t CoreExpr
e -> CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
GHC.Tick CoreTickish
t (CoreExpr -> CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e
      e :: CoreExpr
e@(GHC.Coercion CoercionR
_) -> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
e
      e :: CoreExpr
e@(GHC.Lit Literal
_) -> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
e
      e :: CoreExpr
e@(GHC.Var Var
_) -> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
e
      e :: CoreExpr
e@(GHC.Type Type
_) -> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
e

-- | Behaves the same as 'compileMarkedExpr', unless a compilation error occurs ;
-- if a compilation error happens and the 'defer-errors' option is turned on,
-- the compilation error is suppressed and the original hs expression is replaced with a
-- haskell runtime-error expression.
compileMarkedExprOrDefer ::
    String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr
compileMarkedExprOrDefer :: CommandLineOption
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprOrDefer CommandLineOption
locStr Type
codeTy CoreExpr
origE = do
    PluginOptions
opts <- (PluginCtx -> PluginOptions)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     PluginOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> PluginOptions
pcOpts
    let compileAct :: ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  CoreExpr
compileAct = CommandLineOption
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExpr CommandLineOption
locStr Type
codeTy CoreExpr
origE
    if PluginOptions -> Bool
_posDeferErrors PluginOptions
opts
      -- TODO: we could perhaps move this catchError to the "runExceptT" module-level, but
      -- it leads to uglier code and difficulty of handling other pure errors
      then ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  CoreExpr
compileAct ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  CoreExpr
-> (CompileError DefaultUni DefaultFun Ann
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
         CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  a
-> (CompileError DefaultUni DefaultFun Ann
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
         a)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` Type
-> CompileError DefaultUni DefaultFun Ann
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (uni :: * -> *) fun.
(PrettyUni uni, Pretty fun) =>
Type -> CompileError uni fun Ann -> PluginM uni fun CoreExpr
emitRuntimeError Type
codeTy
      else ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  CoreExpr
compileAct

-- | Given an expected Haskell type 'a', it generates Haskell code which throws a GHC runtime error
-- \"as\" 'CompiledCode a'.
emitRuntimeError
    :: (PLC.PrettyUni uni, PP.Pretty fun)
    => GHC.Type -> CompileError uni fun Ann -> PluginM uni fun GHC.CoreExpr
emitRuntimeError :: forall (uni :: * -> *) fun.
(PrettyUni uni, Pretty fun) =>
Type -> CompileError uni fun Ann -> PluginM uni fun CoreExpr
emitRuntimeError Type
codeTy CompileError uni fun Ann
e = do
    PluginOptions
opts <- (PluginCtx -> PluginOptions)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) PluginOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> PluginOptions
pcOpts
    let shown :: CommandLineOption
shown = Doc Any -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (Doc Any -> CommandLineOption) -> Doc Any -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ CompileError uni fun Ann -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. CompileError uni fun Ann -> Doc ann
PP.pretty (Int -> CompileError uni fun Ann -> CompileError uni fun Ann
forall c e. Int -> WithContext c e -> WithContext c e
pruneContext (PluginOptions -> Int
_posContextLevel PluginOptions
opts) CompileError uni fun Ann
e)
    Name
tcName <- Name -> PluginM uni fun Name
forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail ''CompiledCode
    TyCon
tc <- ExceptT (CompileError uni fun Ann) CoreM TyCon
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError uni fun Ann) CoreM TyCon
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon)
-> (CoreM TyCon -> ExceptT (CompileError uni fun Ann) CoreM TyCon)
-> CoreM TyCon
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM TyCon -> ExceptT (CompileError uni fun Ann) CoreM TyCon
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError uni fun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM TyCon
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon)
-> CoreM TyCon
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon
forall a b. (a -> b) -> a -> b
$ Name -> CoreM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
GHC.lookupTyCon Name
tcName
#if MIN_VERSION_ghc(9,6,0)
    CoreExpr -> PluginM uni fun CoreExpr
forall a.
a -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> PluginM uni fun CoreExpr)
-> CoreExpr -> PluginM uni fun CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> CommandLineOption -> CoreExpr
GHC.mkImpossibleExpr (TyCon -> [Type] -> Type
GHC.mkTyConApp TyCon
tc [Type
codeTy]) CommandLineOption
shown
#else
    pure $ GHC.mkRuntimeErrorApp GHC.rUNTIME_ERROR_ID (GHC.mkTyConApp tc [codeTy]) shown
#endif

-- | Compile the core expression that is surrounded by a 'plc' marker,
-- and return a core expression which evaluates to the compiled plc AST as a serialized bytestring,
-- to be injected back to the Haskell program.
compileMarkedExpr ::
    String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr
compileMarkedExpr :: CommandLineOption
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExpr CommandLineOption
locStr Type
codeTy CoreExpr
origE = do
    DynFlags
flags <- ReaderT
  PluginCtx
  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
  DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
    FamInstEnvs
famEnvs <- (PluginCtx -> FamInstEnvs)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     FamInstEnvs
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> FamInstEnvs
pcFamEnvs
    PluginOptions
opts <- (PluginCtx -> PluginOptions)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     PluginOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> PluginOptions
pcOpts
    ModuleName
moduleName <- (PluginCtx -> ModuleName)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     ModuleName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> ModuleName
pcModuleName
    let moduleNameStr :: CommandLineOption
moduleNameStr =
            DynFlags -> UnitState -> NamePprCtx -> SDoc -> CommandLineOption
GHC.showSDocForUser DynFlags
flags UnitState
GHC.emptyUnitState NamePprCtx
GHC.alwaysQualify (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr ModuleName
moduleName)
    -- We need to do this out here, since it has to run in CoreM
    NameInfo
nameInfo <- [Name] -> PluginM DefaultUni DefaultFun NameInfo
forall (uni :: * -> *) fun. [Name] -> PluginM uni fun NameInfo
makePrimitiveNameInfo ([Name] -> PluginM DefaultUni DefaultFun NameInfo)
-> [Name] -> PluginM DefaultUni DefaultFun NameInfo
forall a b. (a -> b) -> a -> b
$
        [Name]
builtinNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
          [''Bool
          , 'False
          , 'True
          , 'traceBool
          , 'GHC.Num.Integer.integerNegate
          , '(PlutusTx.Bool.&&)
          , '(PlutusTx.Bool.||)
          , 'useToOpaque
          , 'useFromOpaque
          , 'mkNilOpaque
          ]
    Maybe ModBreaks
modBreaks <- (PluginCtx -> Maybe ModBreaks)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Maybe ModBreaks)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PluginCtx -> Maybe ModBreaks
pcModuleModBreaks
    let coverage :: CoverageOpts
coverage = Set CoverageType -> CoverageOpts
CoverageOpts (Set CoverageType -> CoverageOpts)
-> ([CoverageType] -> Set CoverageType)
-> [CoverageType]
-> CoverageOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoverageType] -> Set CoverageType
forall a. Ord a => [a] -> Set a
Set.fromList ([CoverageType] -> CoverageOpts) -> [CoverageType] -> CoverageOpts
forall a b. (a -> b) -> a -> b
$
                   [ CoverageType
l | PluginOptions -> Bool
_posCoverageAll PluginOptions
opts, CoverageType
l <- [CoverageType
forall a. Bounded a => a
minBound .. CoverageType
forall a. Bounded a => a
maxBound]]
                [CoverageType] -> [CoverageType] -> [CoverageType]
forall a. [a] -> [a] -> [a]
++ [ CoverageType
LocationCoverage  | PluginOptions -> Bool
_posCoverageLocation PluginOptions
opts  ]
                [CoverageType] -> [CoverageType] -> [CoverageType]
forall a. [a] -> [a] -> [a]
++ [ CoverageType
BooleanCoverage  | PluginOptions -> Bool
_posCoverageBoolean PluginOptions
opts  ]
    let ctx :: CompileContext DefaultUni DefaultFun
ctx = CompileContext {
            ccOpts :: CompileOptions
ccOpts = CompileOptions {
                coProfile :: ProfileOpts
coProfile=PluginOptions -> ProfileOpts
_posProfile PluginOptions
opts
                ,coCoverage :: CoverageOpts
coCoverage=CoverageOpts
coverage
                ,coRemoveTrace :: Bool
coRemoveTrace=PluginOptions -> Bool
_posRemoveTrace PluginOptions
opts},
            ccFlags :: DynFlags
ccFlags = DynFlags
flags,
            ccFamInstEnvs :: FamInstEnvs
ccFamInstEnvs = FamInstEnvs
famEnvs,
            ccNameInfo :: NameInfo
ccNameInfo = NameInfo
nameInfo,
            ccScope :: Scope DefaultUni
ccScope = Scope DefaultUni
forall (uni :: * -> *). Scope uni
initialScope,
            ccBlackholed :: Set Name
ccBlackholed = Set Name
forall a. Monoid a => a
mempty,
            ccCurDef :: Maybe LexName
ccCurDef = Maybe LexName
forall a. Maybe a
Nothing,
            ccModBreaks :: Maybe ModBreaks
ccModBreaks = Maybe ModBreaks
modBreaks,
            ccBuiltinsInfo :: BuiltinsInfo DefaultUni DefaultFun
ccBuiltinsInfo = BuiltinsInfo DefaultUni DefaultFun
forall a. Default a => a
def,
            ccBuiltinCostModel :: CostingPart DefaultUni DefaultFun
ccBuiltinCostModel = BuiltinCostModel
CostingPart DefaultUni DefaultFun
forall a. Default a => a
def,
            ccDebugTraceOn :: Bool
ccDebugTraceOn = PluginOptions -> Bool
_posDumpCompilationTrace PluginOptions
opts,
            ccRewriteRules :: RewriteRules DefaultUni DefaultFun
ccRewriteRules = PluginOptions -> RewriteRules DefaultUni DefaultFun
makeRewriteRules PluginOptions
opts
            }
        st :: CompileState
st = Int -> [Int] -> CompileState
CompileState Int
0 [Int]
forall a. Monoid a => a
mempty
    -- See Note [Occurrence analysis]
    let origE' :: CoreExpr
origE' = CoreExpr -> CoreExpr
GHC.occurAnalyseExpr CoreExpr
origE

    ((PIRProgram DefaultUni DefaultFun
pirP,UPLCProgram DefaultUni DefaultFun
uplcP), CoverageIndex
covIdx) <- WriterT
  CoverageIndex
  (ReaderT
     PluginCtx (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))
  (PIRProgram DefaultUni DefaultFun,
   UPLCProgram DefaultUni DefaultFun)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     ((PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun),
      CoverageIndex)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT
   CoverageIndex
   (ReaderT
      PluginCtx (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      ((PIRProgram DefaultUni DefaultFun,
        UPLCProgram DefaultUni DefaultFun),
       CoverageIndex))
-> (StateT
      CompileState
      (ReaderT
         (CompileContext DefaultUni DefaultFun)
         (QuoteT
            (WriterT
               CoverageIndex
               (ReaderT
                  PluginCtx
                  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun)
    -> WriterT
         CoverageIndex
         (ReaderT
            PluginCtx (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))
         (PIRProgram DefaultUni DefaultFun,
          UPLCProgram DefaultUni DefaultFun))
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     ((PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun),
      CoverageIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuoteT
  (WriterT
     CoverageIndex
     (ReaderT
        PluginCtx
        (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
  (PIRProgram DefaultUni DefaultFun,
   UPLCProgram DefaultUni DefaultFun)
-> WriterT
     CoverageIndex
     (ReaderT
        PluginCtx (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT (QuoteT
   (WriterT
      CoverageIndex
      (ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> WriterT
      CoverageIndex
      (ReaderT
         PluginCtx (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun))
-> (StateT
      CompileState
      (ReaderT
         (CompileContext DefaultUni DefaultFun)
         (QuoteT
            (WriterT
               CoverageIndex
               (ReaderT
                  PluginCtx
                  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun)
    -> QuoteT
         (WriterT
            CoverageIndex
            (ReaderT
               PluginCtx
               (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
         (PIRProgram DefaultUni DefaultFun,
          UPLCProgram DefaultUni DefaultFun))
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> WriterT
     CoverageIndex
     (ReaderT
        PluginCtx (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
   (CompileContext DefaultUni DefaultFun)
   (QuoteT
      (WriterT
         CoverageIndex
         (ReaderT
            PluginCtx
            (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> CompileContext DefaultUni DefaultFun
 -> QuoteT
      (WriterT
         CoverageIndex
         (ReaderT
            PluginCtx
            (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun))
-> CompileContext DefaultUni DefaultFun
-> ReaderT
     (CompileContext DefaultUni DefaultFun)
     (QuoteT
        (WriterT
           CoverageIndex
           (ReaderT
              PluginCtx
              (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> QuoteT
     (WriterT
        CoverageIndex
        (ReaderT
           PluginCtx
           (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompileContext DefaultUni DefaultFun)
  (QuoteT
     (WriterT
        CoverageIndex
        (ReaderT
           PluginCtx
           (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
  (PIRProgram DefaultUni DefaultFun,
   UPLCProgram DefaultUni DefaultFun)
-> CompileContext DefaultUni DefaultFun
-> QuoteT
     (WriterT
        CoverageIndex
        (ReaderT
           PluginCtx
           (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompileContext DefaultUni DefaultFun
ctx (ReaderT
   (CompileContext DefaultUni DefaultFun)
   (QuoteT
      (WriterT
         CoverageIndex
         (ReaderT
            PluginCtx
            (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> QuoteT
      (WriterT
         CoverageIndex
         (ReaderT
            PluginCtx
            (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun))
-> (StateT
      CompileState
      (ReaderT
         (CompileContext DefaultUni DefaultFun)
         (QuoteT
            (WriterT
               CoverageIndex
               (ReaderT
                  PluginCtx
                  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun)
    -> ReaderT
         (CompileContext DefaultUni DefaultFun)
         (QuoteT
            (WriterT
               CoverageIndex
               (ReaderT
                  PluginCtx
                  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
         (PIRProgram DefaultUni DefaultFun,
          UPLCProgram DefaultUni DefaultFun))
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> QuoteT
     (WriterT
        CoverageIndex
        (ReaderT
           PluginCtx
           (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
   CompileState
   (ReaderT
      (CompileContext DefaultUni DefaultFun)
      (QuoteT
         (WriterT
            CoverageIndex
            (ReaderT
               PluginCtx
               (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> CompileState
 -> ReaderT
      (CompileContext DefaultUni DefaultFun)
      (QuoteT
         (WriterT
            CoverageIndex
            (ReaderT
               PluginCtx
               (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun))
-> CompileState
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> ReaderT
     (CompileContext DefaultUni DefaultFun)
     (QuoteT
        (WriterT
           CoverageIndex
           (ReaderT
              PluginCtx
              (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  CompileState
  (ReaderT
     (CompileContext DefaultUni DefaultFun)
     (QuoteT
        (WriterT
           CoverageIndex
           (ReaderT
              PluginCtx
              (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
  (PIRProgram DefaultUni DefaultFun,
   UPLCProgram DefaultUni DefaultFun)
-> CompileState
-> ReaderT
     (CompileContext DefaultUni DefaultFun)
     (QuoteT
        (WriterT
           CoverageIndex
           (ReaderT
              PluginCtx
              (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT CompileState
st (StateT
   CompileState
   (ReaderT
      (CompileContext DefaultUni DefaultFun)
      (QuoteT
         (WriterT
            CoverageIndex
            (ReaderT
               PluginCtx
               (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      ((PIRProgram DefaultUni DefaultFun,
        UPLCProgram DefaultUni DefaultFun),
       CoverageIndex))
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     ((PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun),
      CoverageIndex)
forall a b. (a -> b) -> a -> b
$
        Int
-> SDoc
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
1 (SDoc
"Compiling expr at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
GHC.text CommandLineOption
locStr) (StateT
   CompileState
   (ReaderT
      (CompileContext DefaultUni DefaultFun)
      (QuoteT
         (WriterT
            CoverageIndex
            (ReaderT
               PluginCtx
               (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
   (PIRProgram DefaultUni DefaultFun,
    UPLCProgram DefaultUni DefaultFun)
 -> StateT
      CompileState
      (ReaderT
         (CompileContext DefaultUni DefaultFun)
         (QuoteT
            (WriterT
               CoverageIndex
               (ReaderT
                  PluginCtx
                  (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
      (PIRProgram DefaultUni DefaultFun,
       UPLCProgram DefaultUni DefaultFun))
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall a b. (a -> b) -> a -> b
$
            CommandLineOption
-> PluginOptions
-> CoreExpr
-> StateT
     CompileState
     (ReaderT
        (CompileContext DefaultUni DefaultFun)
        (QuoteT
           (WriterT
              CoverageIndex
              (ReaderT
                 PluginCtx
                 (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)))))
     (PIRProgram DefaultUni DefaultFun,
      UPLCProgram DefaultUni DefaultFun)
forall (uni :: * -> *) fun (m :: * -> *).
(uni ~ DefaultUni, fun ~ DefaultFun,
 MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadWriter CoverageIndex m, MonadQuote m,
 MonadError (CompileError uni fun Ann) m, MonadIO m) =>
CommandLineOption
-> PluginOptions
-> CoreExpr
-> m (PIRProgram uni fun, UPLCProgram uni fun)
runCompiler CommandLineOption
moduleNameStr PluginOptions
opts CoreExpr
origE'

    -- serialize the PIR, PLC, and coverageindex outputs into a bytestring.
    CoreExpr
bsPir <- ByteString
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (uni :: * -> *) fun. ByteString -> PluginM uni fun CoreExpr
makeByteStringLiteral (ByteString
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> ByteString
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b. (a -> b) -> a -> b
$ PIRProgram DefaultUni DefaultFun -> ByteString
forall a. Flat a => a -> ByteString
flat PIRProgram DefaultUni DefaultFun
pirP
    CoreExpr
bsPlc <- ByteString
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (uni :: * -> *) fun. ByteString -> PluginM uni fun CoreExpr
makeByteStringLiteral (ByteString
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> ByteString
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b. (a -> b) -> a -> b
$ UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun SrcSpans
-> ByteString
forall a. Flat a => a -> ByteString
flat (UPLCProgram DefaultUni DefaultFun
-> UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun SrcSpans
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram UPLCProgram DefaultUni DefaultFun
uplcP)
    CoreExpr
covIdxFlat <- ByteString
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall (uni :: * -> *) fun. ByteString -> PluginM uni fun CoreExpr
makeByteStringLiteral (ByteString
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> ByteString
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b. (a -> b) -> a -> b
$ CoverageIndex -> ByteString
forall a. Flat a => a -> ByteString
flat CoverageIndex
covIdx

    Var
builder <- ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Var
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Var
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Var
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      Var)
-> (Name
    -> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Var)
-> Name
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM Var
-> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Var
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError DefaultUni DefaultFun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM Var
 -> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Var)
-> (Name -> CoreM Var)
-> Name
-> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM Var
forall (m :: * -> *). MonadThings m => Name -> m Var
GHC.lookupId (Name
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      Var)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Name
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Var
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Name
forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail 'mkCompiledCode

    -- inject the three bytestrings back as Haskell code.
    CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      CoreExpr)
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
forall a b. (a -> b) -> a -> b
$
        Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
builder
        CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`GHC.App` Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
codeTy
        CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`GHC.App` CoreExpr
bsPlc
        CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`GHC.App` CoreExpr
bsPir
        CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`GHC.App` CoreExpr
covIdxFlat

-- | The GHC.Core to PIR to PLC compiler pipeline. Returns both the PIR and PLC output.
-- It invokes the whole compiler chain:  Core expr -> PIR expr -> PLC expr -> UPLC expr.
runCompiler ::
    forall uni fun m.
    ( uni ~ PLC.DefaultUni
    , fun ~ PLC.DefaultFun
    , MonadReader (CompileContext uni fun) m
    , MonadState CompileState m
    , MonadWriter CoverageIndex m
    , MonadQuote m
    , MonadError (CompileError uni fun Ann) m
    , MonadIO m
    ) =>
    String ->
    PluginOptions ->
    GHC.CoreExpr ->
    m (PIRProgram uni fun, UPLCProgram uni fun)
runCompiler :: forall (uni :: * -> *) fun (m :: * -> *).
(uni ~ DefaultUni, fun ~ DefaultFun,
 MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadWriter CoverageIndex m, MonadQuote m,
 MonadError (CompileError uni fun Ann) m, MonadIO m) =>
CommandLineOption
-> PluginOptions
-> CoreExpr
-> m (PIRProgram uni fun, UPLCProgram uni fun)
runCompiler CommandLineOption
moduleName PluginOptions
opts CoreExpr
expr = do
    -- Plc configuration
    TypeCheckConfig uni fun
plcTcConfig <- Provenance Ann -> m (TypeCheckConfig uni fun)
forall err term (uni :: * -> *) fun ann (m :: * -> *).
(MonadKindCheck err term uni fun ann m, Typecheckable uni fun) =>
ann -> m (TypeCheckConfig uni fun)
PLC.getDefTypeCheckConfig Provenance Ann
forall a. Provenance a
PIR.noProvenance
    let plcVersion :: Version
plcVersion = PluginOptions
opts PluginOptions -> Getting Version PluginOptions Version -> Version
forall s a. s -> Getting a s a -> a
^. Getting Version PluginOptions Version
Lens' PluginOptions Version
posPlcTargetVersion

    let hints :: InlineHints name (Provenance Ann)
hints = (Provenance Ann -> name -> Bool)
-> InlineHints name (Provenance Ann)
forall name a. (a -> name -> Bool) -> InlineHints name a
UPLC.InlineHints ((Provenance Ann -> name -> Bool)
 -> InlineHints name (Provenance Ann))
-> (Provenance Ann -> name -> Bool)
-> InlineHints name (Provenance Ann)
forall a b. (a -> b) -> a -> b
$ \Provenance Ann
ann name
_ -> case Provenance Ann
ann of
            -- See Note [The problem of inlining destructors]
            -- We want to inline destructors, but even in UPLC our inlining heuristics
            -- aren't quite smart enough to tell that they're good inlining candidates,
            -- so we just explicitly tell the inliner to inline them all.
            --
            -- In fact, this instructs the inliner to inline *any* binding inside a destructor,
            -- which is a slightly large hammer but is actually what we want since it will mean
            -- that we also aggressively reduce the bindings inside the destructor.
            PIR.DatatypeComponent DatatypeComponent
PIR.Destructor Provenance Ann
_ -> Bool
True
            Provenance Ann
_                                      ->
                Inline
AlwaysInline Inline -> [Inline] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Ann -> Inline) -> [Ann] -> [Inline]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> Inline
annInline (Provenance Ann -> [Ann]
forall a. Provenance a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Provenance Ann
ann)

    RewriteRules uni fun
rewriteRules <- (CompileContext uni fun -> RewriteRules uni fun)
-> m (RewriteRules uni fun)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompileContext uni fun -> RewriteRules uni fun
forall (uni :: * -> *) fun.
CompileContext uni fun -> RewriteRules uni fun
ccRewriteRules

    -- Compilation configuration
    -- pir's tc-config is based on plc tcconfig
    let pirTcConfig :: PirTCConfig uni fun
pirTcConfig = TypeCheckConfig uni fun -> AllowEscape -> PirTCConfig uni fun
forall (uni :: * -> *) fun.
TypeCheckConfig uni fun -> AllowEscape -> PirTCConfig uni fun
PIR.PirTCConfig TypeCheckConfig uni fun
plcTcConfig AllowEscape
PIR.YesEscape
        pirCtx :: CompilationCtx uni fun Ann
pirCtx = TypeCheckConfig uni fun -> CompilationCtx uni fun Ann
forall (uni :: * -> *) fun a.
(Default (BuiltinsInfo uni fun), Default (CostingPart uni fun),
 Default (RewriteRules uni fun)) =>
TypeCheckConfig uni fun -> CompilationCtx uni fun a
PIR.toDefaultCompilationCtx TypeCheckConfig uni fun
plcTcConfig
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coOptimize) (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posOptimize)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coTypecheck) (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoTypecheck)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coPedantic) (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posPedantic)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coVerbose) (PluginOptions
opts PluginOptions
-> Getting Verbosity PluginOptions Verbosity -> Verbosity
forall s a. s -> Getting a s a -> a
^. Getting Verbosity PluginOptions Verbosity
Lens' PluginOptions Verbosity
posVerbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDebug) (PluginOptions
opts PluginOptions
-> Getting Verbosity PluginOptions Verbosity -> Verbosity
forall s a. s -> Getting a s a -> a
^. Getting Verbosity PluginOptions Verbosity
Lens' PluginOptions Verbosity
posVerbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Debug)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Int Int
-> Int -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Int -> Identity Int)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Int -> f Int) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coMaxSimplifierIterations)
                    (PluginOptions
opts PluginOptions -> Getting Int PluginOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PluginOptions Int
Lens' PluginOptions Int
posMaxSimplifierIterationsPir)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (PirTCConfig uni fun)
  (PirTCConfig uni fun)
-> PirTCConfig uni fun
-> CompilationCtx uni fun Ann
-> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (PirTCConfig uni fun)
  (PirTCConfig uni fun)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(PirTCConfig uni fun -> f (PirTCConfig uni fun))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccTypeCheckConfig PirTCConfig uni fun
pirTcConfig
                 -- Simplifier options
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDoSimplifierUnwrapCancel)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoSimplifierUnwrapCancel)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDoSimplifierBeta)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoSimplifierBeta)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDoSimplifierInline)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoSimplifierInline)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDoSimplifierEvaluateBuiltins)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoSimplifierEvaluateBuiltins)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDoSimplifierStrictifyBindings)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoSimplifierStrictifyBindings)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coDoSimplifierRemoveDeadBindings)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoSimplifierRemoveDeadBindings)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coInlineConstants)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posInlineConstants)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (InlineHints Name (Provenance Ann))
  (InlineHints Name (Provenance Ann))
-> InlineHints Name (Provenance Ann)
-> CompilationCtx uni fun Ann
-> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((InlineHints Name (Provenance Ann)
     -> Identity (InlineHints Name (Provenance Ann)))
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann)
     (CompilationCtx uni fun Ann)
     (InlineHints Name (Provenance Ann))
     (InlineHints Name (Provenance Ann))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InlineHints Name (Provenance Ann)
 -> Identity (InlineHints Name (Provenance Ann)))
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a1 a2 (f :: * -> *).
Functor f =>
(InlineHints Name (Provenance a1)
 -> f (InlineHints Name (Provenance a2)))
-> CompilationOpts a1 -> f (CompilationOpts a2)
PIR.coInlineHints)                    InlineHints Name (Provenance Ann)
forall {name}. InlineHints name (Provenance Ann)
hints
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coRelaxedFloatin) (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posRelaxedFloatin)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coCaseOfCaseConservative)
                    (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posCaseOfCaseConservative)
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
-> Bool -> CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann) (CompilationCtx uni fun Ann) Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> CompilationOpts a -> f (CompilationOpts a)
PIR.coPreserveLogging) (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posPreserveLogging)
                 -- We could make this configurable with an option, but:
                 -- 1. The only other choice you can make is new version + Scott encoding, and
                 -- there's really no reason to pick that
                 -- 2. This is consistent with what we do in Lift
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  DatatypeStyle
  DatatypeStyle
-> DatatypeStyle
-> CompilationCtx uni fun Ann
-> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CompilationOpts a -> f (CompilationOpts a))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccOpts ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
 -> CompilationCtx uni fun Ann
 -> Identity (CompilationCtx uni fun Ann))
-> ((DatatypeStyle -> Identity DatatypeStyle)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx uni fun Ann)
     (CompilationCtx uni fun Ann)
     DatatypeStyle
     DatatypeStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatatypeCompilationOpts -> Identity DatatypeCompilationOpts)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(DatatypeCompilationOpts -> f DatatypeCompilationOpts)
-> CompilationOpts a -> f (CompilationOpts a)
PIR.coDatatypes ((DatatypeCompilationOpts -> Identity DatatypeCompilationOpts)
 -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ((DatatypeStyle -> Identity DatatypeStyle)
    -> DatatypeCompilationOpts -> Identity DatatypeCompilationOpts)
-> (DatatypeStyle -> Identity DatatypeStyle)
-> CompilationOpts Ann
-> Identity (CompilationOpts Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatatypeStyle -> Identity DatatypeStyle)
-> DatatypeCompilationOpts -> Identity DatatypeCompilationOpts
Iso' DatatypeCompilationOpts DatatypeStyle
PIR.dcoStyle)
                    (if Version
plcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
PLC.plcVersion110
                        then DatatypeStyle
PIR.ScottEncoding else DatatypeStyle
PIR.SumsOfProducts)
                 -- TODO: ensure the same as the one used in the plugin
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (BuiltinsInfo uni fun)
  (BuiltinsInfo uni fun)
-> BuiltinsInfo uni fun
-> CompilationCtx uni fun Ann
-> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (BuiltinsInfo uni fun)
  (BuiltinsInfo uni fun)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(BuiltinsInfo uni fun -> f (BuiltinsInfo uni fun))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccBuiltinsInfo BuiltinsInfo uni fun
forall a. Default a => a
def
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  BuiltinCostModel
  BuiltinCostModel
-> BuiltinCostModel
-> CompilationCtx uni fun Ann
-> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  BuiltinCostModel
  BuiltinCostModel
(CostingPart uni fun -> Identity (CostingPart uni fun))
-> CompilationCtx uni fun Ann
-> Identity (CompilationCtx uni fun Ann)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(CostingPart uni fun -> f (CostingPart uni fun))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccBuiltinCostModel BuiltinCostModel
forall a. Default a => a
def
                 CompilationCtx uni fun Ann
-> (CompilationCtx uni fun Ann -> CompilationCtx uni fun Ann)
-> CompilationCtx uni fun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (RewriteRules uni fun)
  (RewriteRules uni fun)
-> RewriteRules uni fun
-> CompilationCtx uni fun Ann
-> CompilationCtx uni fun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx uni fun Ann)
  (CompilationCtx uni fun Ann)
  (RewriteRules uni fun)
  (RewriteRules uni fun)
forall (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(RewriteRules uni fun -> f (RewriteRules uni fun))
-> CompilationCtx uni fun a -> f (CompilationCtx uni fun a)
PIR.ccRewriteRules RewriteRules uni fun
rewriteRules
        plcOpts :: CompilationOpts Name DefaultFun (Provenance Ann)
plcOpts = CompilationOpts Any DefaultFun Any
forall fun name a.
Default (BuiltinSemanticsVariant fun) =>
CompilationOpts name fun a
PLC.defaultCompilationOpts
            CompilationOpts Any DefaultFun Any
-> (CompilationOpts Any DefaultFun Any
    -> CompilationOpts Any DefaultFun Any)
-> CompilationOpts Any DefaultFun Any
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts Any DefaultFun Any)
  (CompilationOpts Any DefaultFun Any)
  Int
  Int
-> Int
-> CompilationOpts Any DefaultFun Any
-> CompilationOpts Any DefaultFun Any
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> CompilationOpts Any DefaultFun Any
-> Identity (CompilationOpts Any DefaultFun Any)
forall name1 fun a1 name2 a2 (f :: * -> *).
Functor f =>
(SimplifyOpts name1 a1 -> f (SimplifyOpts name2 a2))
-> CompilationOpts name1 fun a1 -> f (CompilationOpts name2 fun a2)
PLC.coSimplifyOpts ((SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
 -> CompilationOpts Any DefaultFun Any
 -> Identity (CompilationOpts Any DefaultFun Any))
-> ((Int -> Identity Int)
    -> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> ASetter
     (CompilationOpts Any DefaultFun Any)
     (CompilationOpts Any DefaultFun Any)
     Int
     Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int)
-> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any)
forall name a (f :: * -> *).
Functor f =>
(Int -> f Int) -> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soMaxSimplifierIterations)
                (PluginOptions
opts PluginOptions -> Getting Int PluginOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PluginOptions Int
Lens' PluginOptions Int
posMaxSimplifierIterationsUPlc)
            CompilationOpts Any DefaultFun Any
-> (CompilationOpts Any DefaultFun Any
    -> CompilationOpts Any DefaultFun Any)
-> CompilationOpts Any DefaultFun Any
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts Any DefaultFun Any)
  (CompilationOpts Any DefaultFun Any)
  Int
  Int
-> Int
-> CompilationOpts Any DefaultFun Any
-> CompilationOpts Any DefaultFun Any
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> CompilationOpts Any DefaultFun Any
-> Identity (CompilationOpts Any DefaultFun Any)
forall name1 fun a1 name2 a2 (f :: * -> *).
Functor f =>
(SimplifyOpts name1 a1 -> f (SimplifyOpts name2 a2))
-> CompilationOpts name1 fun a1 -> f (CompilationOpts name2 fun a2)
PLC.coSimplifyOpts ((SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
 -> CompilationOpts Any DefaultFun Any
 -> Identity (CompilationOpts Any DefaultFun Any))
-> ((Int -> Identity Int)
    -> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> ASetter
     (CompilationOpts Any DefaultFun Any)
     (CompilationOpts Any DefaultFun Any)
     Int
     Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int)
-> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any)
forall name a (f :: * -> *).
Functor f =>
(Int -> f Int) -> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soMaxCseIterations)
                (PluginOptions
opts PluginOptions -> Getting Int PluginOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PluginOptions Int
Lens' PluginOptions Int
posMaxCseIterations)
            CompilationOpts Any DefaultFun Any
-> (CompilationOpts Any DefaultFun Any
    -> CompilationOpts Any DefaultFun Any)
-> CompilationOpts Any DefaultFun Any
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts Any DefaultFun Any)
  (CompilationOpts Any DefaultFun Any)
  Bool
  Bool
-> Bool
-> CompilationOpts Any DefaultFun Any
-> CompilationOpts Any DefaultFun Any
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> CompilationOpts Any DefaultFun Any
-> Identity (CompilationOpts Any DefaultFun Any)
forall name1 fun a1 name2 a2 (f :: * -> *).
Functor f =>
(SimplifyOpts name1 a1 -> f (SimplifyOpts name2 a2))
-> CompilationOpts name1 fun a1 -> f (CompilationOpts name2 fun a2)
PLC.coSimplifyOpts ((SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
 -> CompilationOpts Any DefaultFun Any
 -> Identity (CompilationOpts Any DefaultFun Any))
-> ((Bool -> Identity Bool)
    -> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> ASetter
     (CompilationOpts Any DefaultFun Any)
     (CompilationOpts Any DefaultFun Any)
     Bool
     Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any)
forall name a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soConservativeOpts)
                (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posConservativeOpts)
            CompilationOpts Any DefaultFun Any
-> (CompilationOpts Any DefaultFun Any
    -> CompilationOpts Name DefaultFun (Provenance Ann))
-> CompilationOpts Name DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts Any DefaultFun Any)
  (CompilationOpts Name DefaultFun (Provenance Ann))
  (InlineHints Any Any)
  (InlineHints Name (Provenance Ann))
-> InlineHints Name (Provenance Ann)
-> CompilationOpts Any DefaultFun Any
-> CompilationOpts Name DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SimplifyOpts Any Any
 -> Identity (SimplifyOpts Name (Provenance Ann)))
-> CompilationOpts Any DefaultFun Any
-> Identity (CompilationOpts Name DefaultFun (Provenance Ann))
forall name1 fun a1 name2 a2 (f :: * -> *).
Functor f =>
(SimplifyOpts name1 a1 -> f (SimplifyOpts name2 a2))
-> CompilationOpts name1 fun a1 -> f (CompilationOpts name2 fun a2)
PLC.coSimplifyOpts ((SimplifyOpts Any Any
  -> Identity (SimplifyOpts Name (Provenance Ann)))
 -> CompilationOpts Any DefaultFun Any
 -> Identity (CompilationOpts Name DefaultFun (Provenance Ann)))
-> ((InlineHints Any Any
     -> Identity (InlineHints Name (Provenance Ann)))
    -> SimplifyOpts Any Any
    -> Identity (SimplifyOpts Name (Provenance Ann)))
-> ASetter
     (CompilationOpts Any DefaultFun Any)
     (CompilationOpts Name DefaultFun (Provenance Ann))
     (InlineHints Any Any)
     (InlineHints Name (Provenance Ann))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InlineHints Any Any
 -> Identity (InlineHints Name (Provenance Ann)))
-> SimplifyOpts Any Any
-> Identity (SimplifyOpts Name (Provenance Ann))
forall name1 a1 name2 a2 (f :: * -> *).
Functor f =>
(InlineHints name1 a1 -> f (InlineHints name2 a2))
-> SimplifyOpts name1 a1 -> f (SimplifyOpts name2 a2)
UPLC.soInlineHints) InlineHints Name (Provenance Ann)
forall {name}. InlineHints name (Provenance Ann)
hints
            CompilationOpts Name DefaultFun (Provenance Ann)
-> (CompilationOpts Name DefaultFun (Provenance Ann)
    -> CompilationOpts Name DefaultFun (Provenance Ann))
-> CompilationOpts Name DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts Name DefaultFun (Provenance Ann))
  (CompilationOpts Name DefaultFun (Provenance Ann))
  Bool
  Bool
-> Bool
-> CompilationOpts Name DefaultFun (Provenance Ann)
-> CompilationOpts Name DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SimplifyOpts Name (Provenance Ann)
 -> Identity (SimplifyOpts Name (Provenance Ann)))
-> CompilationOpts Name DefaultFun (Provenance Ann)
-> Identity (CompilationOpts Name DefaultFun (Provenance Ann))
forall name1 fun a1 name2 a2 (f :: * -> *).
Functor f =>
(SimplifyOpts name1 a1 -> f (SimplifyOpts name2 a2))
-> CompilationOpts name1 fun a1 -> f (CompilationOpts name2 fun a2)
PLC.coSimplifyOpts ((SimplifyOpts Name (Provenance Ann)
  -> Identity (SimplifyOpts Name (Provenance Ann)))
 -> CompilationOpts Name DefaultFun (Provenance Ann)
 -> Identity (CompilationOpts Name DefaultFun (Provenance Ann)))
-> ((Bool -> Identity Bool)
    -> SimplifyOpts Name (Provenance Ann)
    -> Identity (SimplifyOpts Name (Provenance Ann)))
-> ASetter
     (CompilationOpts Name DefaultFun (Provenance Ann))
     (CompilationOpts Name DefaultFun (Provenance Ann))
     Bool
     Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> SimplifyOpts Name (Provenance Ann)
-> Identity (SimplifyOpts Name (Provenance Ann))
forall name a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soInlineConstants)
                (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posInlineConstants)

    -- GHC.Core -> Pir translation.
    Term TyName Name uni fun (Provenance Ann)
pirT <- Term TyName Name uni fun Ann
-> Term TyName Name uni fun (Provenance Ann)
forall (f :: * -> *) a. Functor f => f a -> f (Provenance a)
original (Term TyName Name uni fun Ann
 -> Term TyName Name uni fun (Provenance Ann))
-> m (Term TyName Name uni fun Ann)
-> m (Term TyName Name uni fun (Provenance Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ann
-> DefT LexName uni fun Ann m (Term TyName Name uni fun Ann)
-> m (Term TyName Name uni fun Ann)
forall (m :: * -> *) key ann (uni :: * -> *) fun.
(Monad m, Ord key) =>
ann
-> DefT key uni fun ann m (Term TyName Name uni fun ann)
-> m (Term TyName Name uni fun ann)
PIR.runDefT Ann
annMayInline (DefT LexName uni fun Ann m (Term TyName Name uni fun Ann)
 -> m (Term TyName Name uni fun Ann))
-> DefT LexName uni fun Ann m (Term TyName Name uni fun Ann)
-> m (Term TyName Name uni fun Ann)
forall a b. (a -> b) -> a -> b
$ CoreExpr
-> DefT LexName uni fun Ann m (Term TyName Name uni fun Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExprWithDefs CoreExpr
expr)
    let pirP :: Program TyName Name uni fun (Provenance Ann)
pirP = Provenance Ann
-> Version
-> Term TyName Name uni fun (Provenance Ann)
-> Program TyName Name uni fun (Provenance Ann)
forall tyname name (uni :: * -> *) fun ann.
ann
-> Version
-> Term tyname name uni fun ann
-> Program tyname name uni fun ann
PIR.Program Provenance Ann
forall a. Provenance a
noProvenance Version
plcVersion Term TyName Name uni fun (Provenance Ann)
pirT
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDumpPir) (m () -> m ()) -> (IO () -> m ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        Program TyName Name uni fun ()
-> CommandLineOption -> CommandLineOption -> IO ()
forall t.
Flat t =>
t -> CommandLineOption -> CommandLineOption -> IO ()
dumpFlat (Program TyName Name uni fun (Provenance Ann)
-> Program TyName Name uni fun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program TyName Name uni fun (Provenance Ann)
pirP) CommandLineOption
"initial PIR program" (CommandLineOption
moduleName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
"_initial.pir-flat")

    -- Pir -> (Simplified) Pir pass. We can then dump/store a more legible PIR program.
    Program TyName Name uni fun (Provenance Ann)
spirP <- (ReaderT
   (CompilationCtx uni fun Ann)
   m
   (Program TyName Name uni fun (Provenance Ann))
 -> CompilationCtx uni fun Ann
 -> m (Program TyName Name uni fun (Provenance Ann)))
-> CompilationCtx uni fun Ann
-> ReaderT
     (CompilationCtx uni fun Ann)
     m
     (Program TyName Name uni fun (Provenance Ann))
-> m (Program TyName Name uni fun (Provenance Ann))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompilationCtx uni fun Ann)
  m
  (Program TyName Name uni fun (Provenance Ann))
-> CompilationCtx uni fun Ann
-> m (Program TyName Name uni fun (Provenance Ann))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationCtx uni fun Ann
pirCtx (ReaderT
   (CompilationCtx uni fun Ann)
   m
   (Program TyName Name uni fun (Provenance Ann))
 -> m (Program TyName Name uni fun (Provenance Ann)))
-> ReaderT
     (CompilationCtx uni fun Ann)
     m
     (Program TyName Name uni fun (Provenance Ann))
-> m (Program TyName Name uni fun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$ Program TyName Name uni fun (Provenance Ann)
-> ReaderT
     (CompilationCtx uni fun Ann)
     m
     (Program TyName Name uni fun (Provenance Ann))
forall (m :: * -> *) e (uni :: * -> *) fun a b.
(Compiling m e uni fun a, b ~ Provenance a) =>
Program TyName Name uni fun b -> m (Program TyName Name uni fun b)
PIR.compileToReadable Program TyName Name uni fun (Provenance Ann)
pirP
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDumpPir) (m () -> m ()) -> (IO () -> m ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        Program TyName Name uni fun ()
-> CommandLineOption -> CommandLineOption -> IO ()
forall t.
Flat t =>
t -> CommandLineOption -> CommandLineOption -> IO ()
dumpFlat (Program TyName Name uni fun (Provenance Ann)
-> Program TyName Name uni fun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program TyName Name uni fun (Provenance Ann)
spirP) CommandLineOption
"simplified PIR program" (CommandLineOption
moduleName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
"_simplified.pir-flat")

    -- (Simplified) Pir -> Plc translation.
    PLCProgram uni fun Ann
plcP <- (ReaderT (CompilationCtx uni fun Ann) m (PLCProgram uni fun Ann)
 -> CompilationCtx uni fun Ann -> m (PLCProgram uni fun Ann))
-> CompilationCtx uni fun Ann
-> ReaderT (CompilationCtx uni fun Ann) m (PLCProgram uni fun Ann)
-> m (PLCProgram uni fun Ann)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (CompilationCtx uni fun Ann) m (PLCProgram uni fun Ann)
-> CompilationCtx uni fun Ann -> m (PLCProgram uni fun Ann)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationCtx uni fun Ann
pirCtx (ReaderT (CompilationCtx uni fun Ann) m (PLCProgram uni fun Ann)
 -> m (PLCProgram uni fun Ann))
-> ReaderT (CompilationCtx uni fun Ann) m (PLCProgram uni fun Ann)
-> m (PLCProgram uni fun Ann)
forall a b. (a -> b) -> a -> b
$ Program TyName Name uni fun (Provenance Ann)
-> ReaderT (CompilationCtx uni fun Ann) m (PLCProgram uni fun Ann)
forall (m :: * -> *) e (uni :: * -> *) fun a b.
(Compiling m e uni fun a, b ~ Provenance a) =>
Program TyName Name uni fun b -> m (PLCProgram uni fun a)
PIR.compileReadableToPlc Program TyName Name uni fun (Provenance Ann)
spirP
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDumpPlc) (m () -> m ()) -> (IO () -> m ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        Program TyName Name uni fun ()
-> CommandLineOption -> CommandLineOption -> IO ()
forall t.
Flat t =>
t -> CommandLineOption -> CommandLineOption -> IO ()
dumpFlat (PLCProgram uni fun Ann -> Program TyName Name uni fun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void PLCProgram uni fun Ann
plcP) CommandLineOption
"typed PLC program" (CommandLineOption
moduleName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
".tplc-flat")

    -- We do this after dumping the programs so that if we fail typechecking we still get the dump.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDoTypecheck) (m () -> m ())
-> (m (Normalized (Type TyName uni ())) -> m ())
-> m (Normalized (Type TyName uni ()))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Normalized (Type TyName uni ())) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Normalized (Type TyName uni ())) -> m ())
-> m (Normalized (Type TyName uni ())) -> m ()
forall a b. (a -> b) -> a -> b
$
        ExceptT
  (Error DefaultUni DefaultFun Ann)
  m
  (Normalized (Type TyName uni ()))
-> m (Normalized (Type TyName uni ()))
forall b. ExceptT (Error DefaultUni DefaultFun Ann) m b -> m b
liftExcept (ExceptT
   (Error DefaultUni DefaultFun Ann)
   m
   (Normalized (Type TyName uni ()))
 -> m (Normalized (Type TyName uni ())))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Normalized (Type TyName uni ()))
-> m (Normalized (Type TyName uni ()))
forall a b. (a -> b) -> a -> b
$ TypeCheckConfig uni fun
-> Program TyName Name uni fun Ann
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Normalized (Type TyName uni ()))
forall err (uni :: * -> *) fun ann (m :: * -> *).
MonadTypeCheckPlc err uni fun ann m =>
TypeCheckConfig uni fun
-> Program TyName Name uni fun ann
-> m (Normalized (Type TyName uni ()))
PLC.inferTypeOfProgram TypeCheckConfig uni fun
plcTcConfig (PLCProgram uni fun Ann
plcP PLCProgram uni fun Ann -> Ann -> Program TyName Name uni fun Ann
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ann
annMayInline)

    Program Name uni fun (Provenance Ann)
uplcP <- (ReaderT
   (CompilationOpts Name DefaultFun (Provenance Ann))
   m
   (Program Name uni fun (Provenance Ann))
 -> CompilationOpts Name DefaultFun (Provenance Ann)
 -> m (Program Name uni fun (Provenance Ann)))
-> CompilationOpts Name DefaultFun (Provenance Ann)
-> ReaderT
     (CompilationOpts Name DefaultFun (Provenance Ann))
     m
     (Program Name uni fun (Provenance Ann))
-> m (Program Name uni fun (Provenance Ann))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompilationOpts Name DefaultFun (Provenance Ann))
  m
  (Program Name uni fun (Provenance Ann))
-> CompilationOpts Name DefaultFun (Provenance Ann)
-> m (Program Name uni fun (Provenance Ann))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationOpts Name DefaultFun (Provenance Ann)
plcOpts (ReaderT
   (CompilationOpts Name DefaultFun (Provenance Ann))
   m
   (Program Name uni fun (Provenance Ann))
 -> m (Program Name uni fun (Provenance Ann)))
-> ReaderT
     (CompilationOpts Name DefaultFun (Provenance Ann))
     m
     (Program Name uni fun (Provenance Ann))
-> m (Program Name uni fun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$ PLCProgram uni fun Ann
-> ReaderT
     (CompilationOpts Name DefaultFun (Provenance Ann))
     m
     (Program Name uni fun (Provenance Ann))
forall (m :: * -> *) (uni :: * -> *) fun name a tyname.
(Compiling m uni fun name a,
 MonadReader (CompilationOpts name fun a) m) =>
Program tyname name uni fun a -> m (Program name uni fun a)
PLC.compileProgram PLCProgram uni fun Ann
plcP
    Program NamedDeBruijn uni fun (Provenance Ann)
dbP <- ExceptT
  (Error DefaultUni DefaultFun Ann)
  m
  (Program NamedDeBruijn uni fun (Provenance Ann))
-> m (Program NamedDeBruijn uni fun (Provenance Ann))
forall b. ExceptT (Error DefaultUni DefaultFun Ann) m b -> m b
liftExcept (ExceptT
   (Error DefaultUni DefaultFun Ann)
   m
   (Program NamedDeBruijn uni fun (Provenance Ann))
 -> m (Program NamedDeBruijn uni fun (Provenance Ann)))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Program NamedDeBruijn uni fun (Provenance Ann))
-> m (Program NamedDeBruijn uni fun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$ LensLike
  (ExceptT (Error DefaultUni DefaultFun Ann) m)
  (Program Name uni fun (Provenance Ann))
  (Program NamedDeBruijn uni fun (Provenance Ann))
  (Term Name uni fun (Provenance Ann))
  (Term NamedDeBruijn uni fun (Provenance Ann))
-> LensLike
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Program Name uni fun (Provenance Ann))
     (Program NamedDeBruijn uni fun (Provenance Ann))
     (Term Name uni fun (Provenance Ann))
     (Term NamedDeBruijn uni fun (Provenance Ann))
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf LensLike
  (ExceptT (Error DefaultUni DefaultFun Ann) m)
  (Program Name uni fun (Provenance Ann))
  (Program NamedDeBruijn uni fun (Provenance Ann))
  (Term Name uni fun (Provenance Ann))
  (Term NamedDeBruijn uni fun (Provenance Ann))
forall name1 (uni1 :: * -> *) fun1 ann name2 (uni2 :: * -> *) fun2
       (f :: * -> *).
Functor f =>
(Term name1 uni1 fun1 ann -> f (Term name2 uni2 fun2 ann))
-> Program name1 uni1 fun1 ann -> f (Program name2 uni2 fun2 ann)
UPLC.progTerm Term Name uni fun (Provenance Ann)
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Term NamedDeBruijn uni fun (Provenance Ann))
forall e (m :: * -> *) (uni :: * -> *) fun ann.
(AsFreeVariableError e, MonadError e m) =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Program Name uni fun (Provenance Ann)
uplcP
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posDumpUPlc) (m () -> m ()) -> (IO () -> m ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        UnrestrictedProgram NamedDeBruijn uni fun ()
-> CommandLineOption -> CommandLineOption -> IO ()
forall t.
Flat t =>
t -> CommandLineOption -> CommandLineOption -> IO ()
dumpFlat
            (Program NamedDeBruijn uni fun ()
-> UnrestrictedProgram NamedDeBruijn uni fun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram (Program NamedDeBruijn uni fun ()
 -> UnrestrictedProgram NamedDeBruijn uni fun ())
-> Program NamedDeBruijn uni fun ()
-> UnrestrictedProgram NamedDeBruijn uni fun ()
forall a b. (a -> b) -> a -> b
$ Program NamedDeBruijn uni fun (Provenance Ann)
-> Program NamedDeBruijn uni fun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program NamedDeBruijn uni fun (Provenance Ann)
dbP)
            CommandLineOption
"untyped PLC program"
            (CommandLineOption
moduleName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
".uplc-flat")
    -- Discard the Provenance information at this point, just keep the SrcSpans
    -- TODO: keep it and do something useful with it
    (PIRProgram uni fun, UPLCProgram uni fun)
-> m (PIRProgram uni fun, UPLCProgram uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Provenance Ann -> SrcSpans)
-> Program TyName Name uni fun (Provenance Ann)
-> PIRProgram uni fun
forall a b.
(a -> b)
-> Program TyName Name uni fun a -> Program TyName Name uni fun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Provenance Ann -> SrcSpans
getSrcSpans Program TyName Name uni fun (Provenance Ann)
spirP, (Provenance Ann -> SrcSpans)
-> Program NamedDeBruijn uni fun (Provenance Ann)
-> UPLCProgram uni fun
forall a b.
(a -> b)
-> Program NamedDeBruijn uni fun a
-> Program NamedDeBruijn uni fun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Provenance Ann -> SrcSpans
getSrcSpans Program NamedDeBruijn uni fun (Provenance Ann)
dbP)
  where
      -- ugly trick to take out the concrete plc.error and in case of error, map it / rethrow it
      --  using our 'CompileError'
      liftExcept :: ExceptT (PLC.Error PLC.DefaultUni PLC.DefaultFun Ann) m b -> m b
      liftExcept :: forall b. ExceptT (Error DefaultUni DefaultFun Ann) m b -> m b
liftExcept ExceptT (Error DefaultUni DefaultFun Ann) m b
act = do
        Either (Error DefaultUni DefaultFun Ann) b
plcTcError <- ExceptT (Error DefaultUni DefaultFun Ann) m b
-> m (Either (Error DefaultUni DefaultFun Ann) b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (Error DefaultUni DefaultFun Ann) m b
act
        -- also wrap the PLC Error annotations into Original provenances, to match our expected
        -- 'CompileError'
        Either (CompileError DefaultUni DefaultFun Ann) b -> m b
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (CompileError DefaultUni DefaultFun Ann) b -> m b)
-> Either (CompileError DefaultUni DefaultFun Ann) b -> m b
forall a b. (a -> b) -> a -> b
$ (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> Either (Error DefaultUni DefaultFun Ann) b
-> Either (CompileError DefaultUni DefaultFun Ann) b
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Getting
  (CompileError DefaultUni DefaultFun Ann)
  (Error DefaultUni DefaultFun (Provenance Ann))
  (CompileError DefaultUni DefaultFun Ann)
-> Error DefaultUni DefaultFun (Provenance Ann)
-> CompileError DefaultUni DefaultFun Ann
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (AReview
  (CompileError DefaultUni DefaultFun Ann)
  (Error DefaultUni DefaultFun (Provenance Ann))
-> Getter
     (Error DefaultUni DefaultFun (Provenance Ann))
     (CompileError DefaultUni DefaultFun Ann)
forall t b. AReview t b -> Getter b t
re AReview
  (CompileError DefaultUni DefaultFun Ann)
  (Error DefaultUni DefaultFun (Provenance Ann))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun a)
Prism'
  (CompileError DefaultUni DefaultFun Ann)
  (Error DefaultUni DefaultFun (Provenance Ann))
PIR._PLCError) (Error DefaultUni DefaultFun (Provenance Ann)
 -> CompileError DefaultUni DefaultFun Ann)
-> (Error DefaultUni DefaultFun Ann
    -> Error DefaultUni DefaultFun (Provenance Ann))
-> Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> Provenance Ann)
-> Error DefaultUni DefaultFun Ann
-> Error DefaultUni DefaultFun (Provenance Ann)
forall a b.
(a -> b)
-> Error DefaultUni DefaultFun a -> Error DefaultUni DefaultFun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> Provenance Ann
forall a. a -> Provenance a
PIR.Original) Either (Error DefaultUni DefaultFun Ann) b
plcTcError

      dumpFlat :: Flat t => t -> String -> String -> IO ()
      dumpFlat :: forall t.
Flat t =>
t -> CommandLineOption -> CommandLineOption -> IO ()
dumpFlat t
t CommandLineOption
desc CommandLineOption
fileName = do
        (CommandLineOption
tPath, Handle
tHandle) <- CommandLineOption
-> CommandLineOption -> IO (CommandLineOption, Handle)
openBinaryTempFile CommandLineOption
"." CommandLineOption
fileName
        CommandLineOption -> IO ()
putStrLn (CommandLineOption -> IO ()) -> CommandLineOption -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"!!! dumping " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
desc CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" to " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show CommandLineOption
tPath
        Handle -> ByteString -> IO ()
BS.hPut Handle
tHandle (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ t -> ByteString
forall a. Flat a => a -> ByteString
flat t
t

      getSrcSpans :: PIR.Provenance Ann -> SrcSpans
      getSrcSpans :: Provenance Ann -> SrcSpans
getSrcSpans = Set SrcSpan -> SrcSpans
SrcSpans (Set SrcSpan -> SrcSpans)
-> (Provenance Ann -> Set SrcSpan) -> Provenance Ann -> SrcSpans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set SrcSpan] -> Set SrcSpan
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set SrcSpan] -> Set SrcSpan)
-> (Provenance Ann -> [Set SrcSpan])
-> Provenance Ann
-> Set SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> Set SrcSpan) -> [Ann] -> [Set SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpans -> Set SrcSpan
unSrcSpans (SrcSpans -> Set SrcSpan)
-> (Ann -> SrcSpans) -> Ann -> Set SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> SrcSpans
annSrcSpans) ([Ann] -> [Set SrcSpan])
-> (Provenance Ann -> [Ann]) -> Provenance Ann -> [Set SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Provenance Ann -> [Ann]
forall a. Provenance a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Get the 'GHC.Name' corresponding to the given 'TH.Name', or throw an error if we can't get it.
thNameToGhcNameOrFail :: TH.Name -> PluginM uni fun GHC.Name
thNameToGhcNameOrFail :: forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail Name
name = do
    Maybe Name
maybeName <- ExceptT (CompileError uni fun Ann) CoreM (Maybe Name)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) (Maybe Name)
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError uni fun Ann) CoreM (Maybe Name)
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) (Maybe Name))
-> (CoreM (Maybe Name)
    -> ExceptT (CompileError uni fun Ann) CoreM (Maybe Name))
-> CoreM (Maybe Name)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM (Maybe Name)
-> ExceptT (CompileError uni fun Ann) CoreM (Maybe Name)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError uni fun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM (Maybe Name)
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) (Maybe Name))
-> CoreM (Maybe Name)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Name -> CoreM (Maybe Name)
GHC.thNameToGhcName Name
name
    case Maybe Name
maybeName of
        Just Name
n  -> Name -> PluginM uni fun Name
forall a.
a -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
        Maybe Name
Nothing -> CompileError uni fun Ann -> PluginM uni fun Name
forall a.
CompileError uni fun Ann
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError uni fun Ann -> PluginM uni fun Name)
-> (Error uni fun Ann -> CompileError uni fun Ann)
-> Error uni fun Ann
-> PluginM uni fun Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error uni fun Ann -> CompileError uni fun Ann
forall c e. e -> WithContext c e
NoContext (Error uni fun Ann -> PluginM uni fun Name)
-> Error uni fun Ann -> PluginM uni fun Name
forall a b. (a -> b) -> a -> b
$ Name -> Error uni fun Ann
forall (uni :: * -> *) fun a. Name -> Error uni fun a
CoreNameLookupError Name
name

-- | Create a GHC Core expression that will evaluate to the given ByteString at runtime.
makeByteStringLiteral :: BS.ByteString -> PluginM uni fun GHC.CoreExpr
makeByteStringLiteral :: forall (uni :: * -> *) fun. ByteString -> PluginM uni fun CoreExpr
makeByteStringLiteral ByteString
bs = do
    DynFlags
flags <- ReaderT
  PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags

    {-
    This entire section will crash horribly in a number of circumstances. Such is life.
    - If any of the names we need can't be found as GHC Names
    - If we then can't look up those GHC Names to get their IDs/types
    - If we make any mistakes creating the Core expression
    -}

    -- Get the names of functions/types that we need for our expression
    Var
upio <- ExceptT (CompileError uni fun Ann) CoreM Var
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError uni fun Ann) CoreM Var
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var)
-> (Name -> ExceptT (CompileError uni fun Ann) CoreM Var)
-> Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM Var -> ExceptT (CompileError uni fun Ann) CoreM Var
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError uni fun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM Var -> ExceptT (CompileError uni fun Ann) CoreM Var)
-> (Name -> CoreM Var)
-> Name
-> ExceptT (CompileError uni fun Ann) CoreM Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM Var
forall (m :: * -> *). MonadThings m => Name -> m Var
GHC.lookupId (Name
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail 'unsafePerformIO
    TyCon
bsTc <- ExceptT (CompileError uni fun Ann) CoreM TyCon
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError uni fun Ann) CoreM TyCon
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon)
-> (Name -> ExceptT (CompileError uni fun Ann) CoreM TyCon)
-> Name
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM TyCon -> ExceptT (CompileError uni fun Ann) CoreM TyCon
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError uni fun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM TyCon -> ExceptT (CompileError uni fun Ann) CoreM TyCon)
-> (Name -> CoreM TyCon)
-> Name
-> ExceptT (CompileError uni fun Ann) CoreM TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
GHC.lookupTyCon (Name
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail ''BS.ByteString
    Var
upal <- ExceptT (CompileError uni fun Ann) CoreM Var
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError uni fun Ann) CoreM Var
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var)
-> (Name -> ExceptT (CompileError uni fun Ann) CoreM Var)
-> Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM Var -> ExceptT (CompileError uni fun Ann) CoreM Var
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError uni fun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM Var -> ExceptT (CompileError uni fun Ann) CoreM Var)
-> (Name -> CoreM Var)
-> Name
-> ExceptT (CompileError uni fun Ann) CoreM Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM Var
forall (m :: * -> *). MonadThings m => Name -> m Var
GHC.lookupId (Name
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Var
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail 'BSUnsafe.unsafePackAddressLen

    -- We construct the following expression:
    -- unsafePerformIO $
    --     unsafePackAddressLen <length as int literal> <data as string literal address>
    -- This technique gratefully borrowed from the file-embed package

    -- The flags here are so GHC can check whether the int is in range for the current platform.
    let lenLit :: CoreExpr
lenLit = Platform -> Integer -> CoreExpr
GHC.mkIntExpr (DynFlags -> Platform
GHC.targetPlatform DynFlags
flags) (Integer -> CoreExpr) -> Integer -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs
    -- This will have type Addr#, which is right for unsafePackAddressLen
    let bsLit :: CoreExpr
bsLit = Literal -> CoreExpr
forall b. Literal -> Expr b
GHC.Lit (ByteString -> Literal
GHC.LitString ByteString
bs)
    let upaled :: CoreExpr
upaled = CoreExpr -> [CoreExpr] -> CoreExpr
GHC.mkCoreApps (Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
upal) [CoreExpr
lenLit, CoreExpr
bsLit]
    let upioed :: CoreExpr
upioed = CoreExpr -> [CoreExpr] -> CoreExpr
GHC.mkCoreApps (Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
upio) [Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type (TyCon -> Type
GHC.mkTyConTy TyCon
bsTc), CoreExpr
upaled]

    CoreExpr -> PluginM uni fun CoreExpr
forall a.
a -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
upioed

-- | Strips all enclosing 'GHC.Tick's off an expression.
stripTicks :: GHC.CoreExpr -> GHC.CoreExpr
stripTicks :: CoreExpr -> CoreExpr
stripTicks = \case
    GHC.Tick CoreTickish
_ CoreExpr
e -> CoreExpr -> CoreExpr
stripTicks CoreExpr
e
    CoreExpr
e            -> CoreExpr
e

-- | Helper to avoid doing too much construction of Core ourselves
mkCompiledCode :: forall a . BS.ByteString -> BS.ByteString -> BS.ByteString -> CompiledCode a
mkCompiledCode :: forall a. ByteString -> ByteString -> ByteString -> CompiledCode a
mkCompiledCode ByteString
plcBS ByteString
pirBS ByteString
ci = ByteString
-> Maybe ByteString
-> CoverageIndex
-> CompiledCodeIn DefaultUni DefaultFun a
forall (uni :: * -> *) fun a.
ByteString
-> Maybe ByteString -> CoverageIndex -> CompiledCodeIn uni fun a
SerializedCode ByteString
plcBS (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
pirBS) (Either DecodeException CoverageIndex -> CoverageIndex
forall m. Monoid m => Either DecodeException m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Either DecodeException CoverageIndex -> CoverageIndex)
-> (ByteString -> Either DecodeException CoverageIndex)
-> ByteString
-> CoverageIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either DecodeException CoverageIndex
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (ByteString -> CoverageIndex) -> ByteString -> CoverageIndex
forall a b. (a -> b) -> a -> b
$ ByteString
ci)

-- | Make a 'NameInfo' mapping the given set of TH names to their
-- 'GHC.TyThing's for later reference.
makePrimitiveNameInfo :: [TH.Name] -> PluginM uni fun NameInfo
makePrimitiveNameInfo :: forall (uni :: * -> *) fun. [Name] -> PluginM uni fun NameInfo
makePrimitiveNameInfo [Name]
names = do
    [(Name, TyThing)]
infos <- [Name]
-> (Name
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError uni fun Ann) CoreM)
         (Name, TyThing))
-> ReaderT
     PluginCtx
     (ExceptT (CompileError uni fun Ann) CoreM)
     [(Name, TyThing)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Name]
names ((Name
  -> ReaderT
       PluginCtx
       (ExceptT (CompileError uni fun Ann) CoreM)
       (Name, TyThing))
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError uni fun Ann) CoreM)
      [(Name, TyThing)])
-> (Name
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError uni fun Ann) CoreM)
         (Name, TyThing))
-> ReaderT
     PluginCtx
     (ExceptT (CompileError uni fun Ann) CoreM)
     [(Name, TyThing)]
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
        Name
ghcName <- Name -> PluginM uni fun Name
forall (uni :: * -> *) fun. Name -> PluginM uni fun Name
thNameToGhcNameOrFail Name
name
        TyThing
thing <- ExceptT (CompileError uni fun Ann) CoreM TyThing
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyThing
forall (m :: * -> *) a. Monad m => m a -> ReaderT PluginCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (CompileError uni fun Ann) CoreM TyThing
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyThing)
-> (CoreM TyThing
    -> ExceptT (CompileError uni fun Ann) CoreM TyThing)
-> CoreM TyThing
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM TyThing -> ExceptT (CompileError uni fun Ann) CoreM TyThing
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (CompileError uni fun Ann) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CoreM TyThing
 -> ReaderT
      PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyThing)
-> CoreM TyThing
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) TyThing
forall a b. (a -> b) -> a -> b
$ Name -> CoreM TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
GHC.lookupThing Name
ghcName
        (Name, TyThing)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError uni fun Ann) CoreM)
     (Name, TyThing)
forall a.
a -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, TyThing
thing)
    NameInfo -> PluginM uni fun NameInfo
forall a.
a -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameInfo -> PluginM uni fun NameInfo)
-> NameInfo -> PluginM uni fun NameInfo
forall a b. (a -> b) -> a -> b
$ [(Name, TyThing)] -> NameInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, TyThing)]
infos

makeRewriteRules :: PluginOptions -> RewriteRules DefaultUni DefaultFun
makeRewriteRules :: PluginOptions -> RewriteRules DefaultUni DefaultFun
makeRewriteRules PluginOptions
options =
  [RewriteRules DefaultUni DefaultFun]
-> RewriteRules DefaultUni DefaultFun
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Bool
-> RewriteRules DefaultUni DefaultFun
-> RewriteRules DefaultUni DefaultFun
forall a. Monoid a => Bool -> a -> a
mwhen (PluginOptions
options PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posRemoveTrace) RewriteRules DefaultUni DefaultFun
forall (uni :: * -> *). RewriteRules uni DefaultFun
rewriteRuleRemoveTrace
    , RewriteRules DefaultUni DefaultFun
defaultUniRewriteRules
    ]