{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
-- For some reason this module is very slow to compile otherwise
{-# OPTIONS_GHC -O0 #-}

module PlutusTx.Plugin.Common where

import Certifier (CertifierOutput (..), mkCertifier, prettyCertifierError, runCertifier)
import PlutusCore qualified as PLC
import PlutusCore.Compiler qualified as PLC
import PlutusCore.Default (DefaultFun, DefaultUni)
import PlutusCore.Flat (Flat, flat, unflat)
import PlutusCore.Pretty as PLC
import PlutusCore.Quote
import PlutusCore.Version qualified as PLC
import PlutusIR qualified as PIR
import PlutusIR.Compiler qualified as PIR
import PlutusIR.Compiler.Definitions qualified as PIR
import PlutusIR.Compiler.Provenance (noProvenance, original)
import PlutusIR.Compiler.Types qualified as PIR
import PlutusIR.Transform.RewriteRules
import PlutusIR.Transform.RewriteRules.RemoveTrace (rewriteRuleRemoveTrace)
import PlutusPrelude
import PlutusTx.AsData.Internal qualified
import PlutusTx.Bool ((&&), (||))
import PlutusTx.Builtins (equalsInteger, mkNil, mkNilOpaque, useFromOpaque, useToOpaque)
import PlutusTx.Code
import PlutusTx.Compiler.Builtins
import PlutusTx.Compiler.Compat qualified as Compat
import PlutusTx.Compiler.Error
import PlutusTx.Compiler.Expr
import PlutusTx.Compiler.Types
import PlutusTx.Coverage
import PlutusTx.Function qualified
import PlutusTx.List qualified
import PlutusTx.Optimize.Inline qualified
import PlutusTx.Options
import PlutusTx.PIRTypes
import PlutusTx.PLCTypes
import PlutusTx.Plugin.Utils qualified
import PlutusTx.Trace
import UntypedPlutusCore qualified as UPLC

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
import GHC.Core.Rules.Config qualified as GHC
import GHC.Core.TyCo.Rep qualified as GHC
import GHC.Core.Unfold qualified as GHC
import GHC.Hs qualified as GHC
import GHC.Hs.Syn.Type qualified as GHC
import GHC.Iface.Env qualified as GHC
import GHC.Plugins qualified as GHC
import GHC.Tc.Types qualified as GHC
import GHC.Tc.Types.Evidence qualified as GHC
import GHC.Tc.Utils.Env qualified as GHC
import GHC.Tc.Utils.Monad qualified as GHC
import GHC.Types.TyThing qualified as GHC
import GHC.Unit.Finder qualified as GHC

import Control.Exception (SomeException, throwIO, try)
import Control.Lens
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.ByteString qualified as BS
import Data.ByteString.Unsafe qualified as BSUnsafe
import Data.Either.Validation
import Data.Generics.Uniplate.Data
import Data.Map qualified as Map
import Data.Maybe (fromJust, mapMaybe, maybeToList)
import Data.Monoid.Extra (mwhen)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Num.Integer qualified
import Language.Haskell.TH.Syntax as TH hiding (lift)
import Prettyprinter qualified as PP
import System.IO (hPutStrLn, openBinaryTempFile, stderr)
import System.IO.Unsafe (unsafePerformIO)

data PluginCtx = PluginCtx
  { PluginCtx -> PluginOptions
pcOpts :: PluginOptions
  , PluginCtx -> FamInstEnvs
pcFamEnvs :: GHC.FamInstEnvs
  , PluginCtx -> Name
pcMarkerName :: GHC.Name
  , PluginCtx -> Name
pcAnchorName :: 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.
-}

installCorePlugin
  :: TH.Name
  -> [GHC.CommandLineOption]
  -> [GHC.CoreToDo]
  -> GHC.CoreM [GHC.CoreToDo]
installCorePlugin :: Name -> [String] -> [CoreToDo] -> CoreM [CoreToDo]
installCorePlugin Name
markerTHName [String]
args [CoreToDo]
rest = do
  -- create simplifier pass to be placed at the front
  CoreToDo
simplPass <- DynFlags -> CoreToDo
mkSimplPass (DynFlags -> CoreToDo) -> CoreM DynFlags -> CoreM CoreToDo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  -- instantiate our plugin pass
  CoreToDo
pluginPass <-
    Name -> PluginOptions -> CoreToDo
mkPluginPass Name
markerTHName (PluginOptions -> CoreToDo)
-> CoreM PluginOptions -> CoreM CoreToDo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [String] -> Validation ParseErrors PluginOptions
parsePluginOptions [String]
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

plinthcModName, anchorName :: String
plinthcModName :: String
plinthcModName = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Name -> Maybe String
TH.nameModule 'PlutusTx.Plugin.Utils.anchor
anchorName :: String
anchorName = Name -> String
TH.nameBase 'PlutusTx.Plugin.Utils.anchor

-- | Wrap certain @HsExpr@s in the typed checked module with @anchor@.
injectAnchors
  :: GHC.TcGblEnv
  -> GHC.TcM GHC.TcGblEnv
injectAnchors :: TcGblEnv -> TcM TcGblEnv
injectAnchors TcGblEnv
env = do
  HscEnv
hscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
GHC.getTopEnv
  FindResult
findResult <-
    IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult)
-> IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult
forall a b. (a -> b) -> a -> b
$
      HscEnv -> ModuleName -> PkgQual -> IO FindResult
GHC.findImportedModule
        HscEnv
hscEnv
        (String -> ModuleName
GHC.mkModuleName String
plinthcModName)
        PkgQual
GHC.NoPkgQual
  Id
anchorId <- case FindResult
findResult of
    GHC.Found ModLocation
_ Module
m -> do
      Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
GHC.tcLookupId (Name -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> IOEnv (Env TcGblEnv TcLclEnv) Name
-> IOEnv (Env TcGblEnv TcLclEnv) Id
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a b. Module -> OccName -> TcRnIf a b Name
GHC.lookupOrig Module
m (String -> OccName
GHC.mkVarOcc String
anchorName)
    FindResult
_ ->
      String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a. HasCallStack => String -> SDoc -> a
GHC.pprPanic
        String
"Plinth.Plugin"
        (String -> SDoc
forall doc. IsLine doc => String -> doc
GHC.text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Could not find module " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
plinthcModName)
  let binds :: LHsBinds GhcTc
binds = TcGblEnv -> LHsBinds GhcTc
GHC.tcg_binds TcGblEnv
env
      bindsAnchored :: LHsBinds GhcTc
bindsAnchored = ([XRec GhcTc (HsBindLR GhcTc GhcTc)]
 -> [XRec GhcTc (HsBindLR GhcTc GhcTc)])
-> LHsBinds GhcTc -> LHsBinds GhcTc
forall p.
([LHsBindLR p p] -> [LHsBindLR p p]) -> LHsBinds p -> LHsBinds p
Compat.modifyBinds ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
 -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [XRec GhcTc (HsBindLR GhcTc GhcTc)]
-> [XRec GhcTc (HsBindLR GhcTc GhcTc)]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (Id -> LHsExpr GhcTc -> LHsExpr GhcTc
anchorExpr Id
anchorId)) LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds
  TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcGblEnv
env {GHC.tcg_binds = bindsAnchored}

-- | Wrap an @HsExpr@ with @anchor@.
anchorExpr :: GHC.Id -> GHC.LHsExpr GHC.GhcTc -> GHC.LHsExpr GHC.GhcTc
anchorExpr :: Id -> LHsExpr GhcTc -> LHsExpr GhcTc
anchorExpr Id
anchorId le :: LHsExpr GhcTc
le@(GHC.L SrcSpanAnnA
ann HsExpr GhcTc
e)
  | Id -> HsExpr GhcTc -> Bool
isAnchorWorthy Id
anchorId HsExpr GhcTc
e
  , Just !RealSrcSpan
sp <- SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
ann) =
      let locStr :: String
locStr = RealSrcSpan -> String
encodeSrcSpan RealSrcSpan
sp
          locTy :: Type
locTy = TyLit -> Type
GHC.LitTy (FastString -> TyLit
GHC.StrTyLit (String -> FastString
GHC.mkFastString String
locStr))
          exprTy :: Type
exprTy = HsExpr GhcTc -> Type
GHC.hsExprType HsExpr GhcTc
e
          wrapper :: HsWrapper
wrapper = Type -> HsWrapper
GHC.WpTyApp Type
exprTy HsWrapper -> HsWrapper -> HsWrapper
`GHC.WpCompose` Type -> HsWrapper
GHC.WpTyApp Type
locTy
          anchor :: HsExpr GhcTc
anchor = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
GHC.mkHsWrap HsWrapper
wrapper (XVar GhcTc -> XRec GhcTc (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar XVar GhcTc
NoExtField
GHC.noExtField (XRec GhcTc (IdP GhcTc) -> HsExpr GhcTc)
-> XRec GhcTc (IdP GhcTc) -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ Id -> LocatedAn NameAnn Id
forall a an. a -> LocatedAn an a
GHC.noLocA Id
anchorId)
       in HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
GHC.noLocA (LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
Compat.hsAppTc (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
GHC.noLocA HsExpr GhcTc
anchor) LHsExpr GhcTc
le)
  | Bool
otherwise = LHsExpr GhcTc
le

isAnchorWorthy :: GHC.Id -> GHC.HsExpr GHC.GhcTc -> Bool
isAnchorWorthy :: Id -> HsExpr GhcTc -> Bool
isAnchorWorthy Id
marker HsExpr GhcTc
expr
  -- This should never happen since we add anchors bottom-up, but just in case.
  | Id -> HsExpr GhcTc -> Bool
isAnchorApp Id
marker HsExpr GhcTc
expr = Bool
False
  -- @anchor@ only works on lifted types
  | Type -> Bool
GHC.mightBeUnliftedType (HsExpr GhcTc -> Type
GHC.hsExprType HsExpr GhcTc
expr) = Bool
False
  | Bool
otherwise = case HsExpr GhcTc
expr of
      -- We currently only wrap variables with @anchor@. Wrapping more
      -- expressions leads to significantly less optimized GHC Core, because
      -- GHC is unable to optimize it effectively.
      --
      -- However, this should be exactly what we want! Ideally we'd avoid any GHC
      -- optimizations since they don't necessarily preserve Plinth semantics. All
      -- optimization should instead be performed by the PIR/UPLC optimizers. This
      -- suggests there's still significant room for improvement in the PIR/UPLC optimizers.
      GHC.HsVar {} -> Bool
True
      HsExpr GhcTc
_ -> Bool
False

isTick :: GHC.HsExpr GHC.GhcTc -> Bool
isTick :: HsExpr GhcTc -> Bool
isTick = \case
  GHC.XExpr (GHC.HsTick CoreTickish
_ LHsExpr GhcTc
_) -> Bool
True
  HsExpr GhcTc
_ -> Bool
False

isAnchorApp :: GHC.Id -> GHC.HsExpr GHC.GhcTc -> Bool
isAnchorApp :: Id -> HsExpr GhcTc -> Bool
isAnchorApp Id
marker = (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
marker Maybe Id -> Maybe Id -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Id -> Bool)
-> (HsExpr GhcTc -> Maybe Id) -> HsExpr GhcTc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcTc -> Maybe Id
appHead
  where
    appHead :: HsExpr GhcTc -> Maybe Id
appHead = \case
      GHC.HsVar XVar GhcTc
_ (GHC.L SrcSpanAnnN
_ Id
v) -> Id -> Maybe Id
forall a. a -> Maybe a
Just Id
v
      GHC.HsApp XApp GhcTc
_ (GHC.L SrcSpanAnnA
_ HsExpr GhcTc
f) LHsExpr GhcTc
_ -> HsExpr GhcTc -> Maybe Id
appHead HsExpr GhcTc
f
      Compat.HsAppType XAppTypeE GhcTc
_ (GHC.L SrcSpanAnnA
_ HsExpr GhcTc
f) LHsWcType (NoGhcTc GhcTc)
_ -> HsExpr GhcTc -> Maybe Id
appHead HsExpr GhcTc
f
      GHC.XExpr (Compat.WrapExpr HsExpr GhcTc
e) -> HsExpr GhcTc -> Maybe Id
appHead HsExpr GhcTc
e
      Compat.HsPar (GHC.L SrcSpanAnnA
_ HsExpr GhcTc
e) -> HsExpr GhcTc -> Maybe Id
appHead HsExpr GhcTc
e
      HsExpr GhcTc
_ -> Maybe Id
forall a. Maybe a
Nothing

{- 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.CoreToDo
mkSimplPass :: DynFlags -> CoreToDo
mkSimplPass DynFlags
dflags =
  -- See Note [Making sure unfoldings are present]
  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
      }
  where
    simplMode :: SimplMode
simplMode =
      GHC.SimplMode
        { sm_names :: [String]
GHC.sm_names = [String
"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
        , 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
        }

{- Note [Marker resolution]
We use TH's 'foo exact syntax for resolving the marker's ghc name, as explained in:
<https://hackage.haskell.org/package/ghc-9.6.6/docs/GHC-Plugins.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 the marker even in the case that the marker 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 markers and compiles their right-hand-side core
expressions. -}
mkPluginPass :: TH.Name -> PluginOptions -> GHC.CoreToDo
mkPluginPass :: Name -> PluginOptions -> CoreToDo
mkPluginPass Name
markerTHName PluginOptions
opts = String -> CorePluginPass -> CoreToDo
GHC.CoreDoPluginPass String
"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 Name
markerTHName
  Maybe Name
maybeanchorGhcName <- Name -> CoreM (Maybe Name)
GHC.thNameToGhcName 'PlutusTx.Plugin.Utils.anchor
  case (Maybe Name
maybeMarkerName, Maybe Name
maybeanchorGhcName) of
    -- See Note [Marker resolution]
    (Just Name
markerName, Just Name
anchorGhcName) ->
      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
              , pcAnchorName :: Name
pcAnchorName = Name
anchorGhcName
              , pcModuleName :: ModuleName
pcModuleName = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModGuts -> Module
GHC.mg_module ModGuts
guts
              , pcModuleModBreaks :: Maybe ModBreaks
pcModuleModBreaks = ModGuts -> Maybe ModBreaks
GHC.mg_modBreaks ModGuts
guts
              }
       in -- start looking for marker calls from the top-level binds
          (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
    (Maybe Name, Maybe Name)
_ -> CorePluginPass
forall a. a -> CoreM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
  :: forall uni fun a
   . (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 -> 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
$ do
      let errStack :: (Error uni fun Ann, [(Int, (Text, Maybe GHC.RealSrcSpan))])
          errStack :: (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
errStack = ([(Int, (Text, Maybe RealSrcSpan))]
 -> [(Int, (Text, Maybe RealSrcSpan))])
-> (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
-> (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [(Int, (Text, Maybe RealSrcSpan))]
-> [(Int, (Text, Maybe RealSrcSpan))]
forall a. [a] -> [a]
reverse ((Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
 -> (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))]))
-> (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
-> (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
forall a b. (a -> b) -> a -> b
$ CompileError uni fun Ann
-> (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
forall {b} {a}. WithContext b a -> (a, [(Int, b)])
go CompileError uni fun Ann
err
            where
              go :: WithContext b a -> (a, [(Int, b)])
go = \case
                NoContext a
e -> (a
e, [])
                WithContextC Int
p b
c WithContext b a
rest ->
                  let (a
e, [(Int, b)]
cs) = WithContext b a -> (a, [(Int, b)])
go WithContext b a
rest
                   in (a
e, (Int
p, b
c) (Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
: [(Int, b)]
cs)

          truncated :: ([(Int, (Text, Maybe GHC.RealSrcSpan))], Maybe GHC.RealSrcSpan)
          truncated :: ([(Int, (Text, Maybe RealSrcSpan))], Maybe RealSrcSpan)
truncated = [(Int, (Text, Maybe RealSrcSpan))]
-> Maybe RealSrcSpan
-> ([(Int, (Text, Maybe RealSrcSpan))], Maybe RealSrcSpan)
forall {a} {a} {a}.
[(a, (a, Maybe a))] -> Maybe a -> ([(a, (a, Maybe a))], Maybe a)
go ((Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
-> [(Int, (Text, Maybe RealSrcSpan))]
forall a b. (a, b) -> b
snd (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
errStack) Maybe RealSrcSpan
forall a. Maybe a
Nothing
            where
              go :: [(a, (a, Maybe a))] -> Maybe a -> ([(a, (a, Maybe a))], Maybe a)
go [] Maybe a
loc = ([], Maybe a
loc)
              go ((a, (a, Maybe a))
x : [(a, (a, Maybe a))]
xs) Maybe a
loc = case (a, (a, Maybe a))
x of
                (a
_, (a
_, Just a
ss)) -> ([(a, (a, Maybe a))
x], a -> Maybe a
forall a. a -> Maybe a
Just a
ss)
                (a
_, (a
_, Maybe a
Nothing)) ->
                  let ([(a, (a, Maybe a))]
ys, Maybe a
ss) = [(a, (a, Maybe a))] -> Maybe a -> ([(a, (a, Maybe a))], Maybe a)
go [(a, (a, Maybe a))]
xs Maybe a
loc
                   in ((a, (a, Maybe a))
x (a, (a, Maybe a)) -> [(a, (a, Maybe a))] -> [(a, (a, Maybe a))]
forall a. a -> [a] -> [a]
: [(a, (a, Maybe a))]
ys, Maybe a
ss)

          err' :: CompileError uni fun Ann
          err' :: CompileError uni fun Ann
err' = (CompileError uni fun Ann
 -> (Int, (Text, Maybe RealSrcSpan)) -> CompileError uni fun Ann)
-> CompileError uni fun Ann
-> [(Int, (Text, Maybe RealSrcSpan))]
-> CompileError uni fun Ann
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CompileError uni fun Ann
e (Int
p, (Text, Maybe RealSrcSpan)
c) -> Int
-> (Text, Maybe RealSrcSpan)
-> CompileError uni fun Ann
-> CompileError uni fun Ann
forall c e. Int -> c -> WithContext c e -> WithContext c e
WithContextC Int
p (Text, Maybe RealSrcSpan)
c CompileError uni fun Ann
e) (Error uni fun Ann -> CompileError uni fun Ann
forall c e. e -> WithContext c e
NoContext ((Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
-> Error uni fun Ann
forall a b. (a, b) -> a
fst (Error uni fun Ann, [(Int, (Text, Maybe RealSrcSpan))])
errStack)) (([(Int, (Text, Maybe RealSrcSpan))], Maybe RealSrcSpan)
-> [(Int, (Text, Maybe RealSrcSpan))]
forall a b. (a, b) -> a
fst ([(Int, (Text, Maybe RealSrcSpan))], Maybe RealSrcSpan)
truncated)

      Maybe (Doc Any)
snippet <- case ([(Int, (Text, Maybe RealSrcSpan))], Maybe RealSrcSpan)
-> Maybe RealSrcSpan
forall a b. (a, b) -> b
snd ([(Int, (Text, Maybe RealSrcSpan))], Maybe RealSrcSpan)
truncated of
        Maybe RealSrcSpan
Nothing -> Maybe (Doc Any) -> IO (Maybe (Doc Any))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Doc Any)
forall a. Maybe a
Nothing
        Just RealSrcSpan
ss -> RealSrcSpan -> IO (Maybe (Doc Any))
forall ann. RealSrcSpan -> IO (Maybe (Doc ann))
getSourceSnippet RealSrcSpan
ss

      let msg :: Doc Any
msg =
            [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
PP.vsep ([Doc Any] -> Doc Any) -> [Doc Any] -> Doc Any
forall a b. (a -> b) -> a -> b
$
              [ Doc Any
"Plinth Compilation Error:"
              , WithContext Text (Error uni fun Ann) -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. WithContext Text (Error uni fun Ann) -> Doc ann
PP.pretty (((Text, Maybe RealSrcSpan) -> Text)
-> CompileError uni fun Ann -> WithContext Text (Error uni fun Ann)
forall c c' e. (c -> c') -> WithContext c e -> WithContext c' e
mapContext (Text, Maybe RealSrcSpan) -> Text
forall a b. (a, b) -> a
fst CompileError uni fun Ann
err')
              ]
                [Doc Any] -> [Doc Any] -> [Doc Any]
forall a. [a] -> [a] -> [a]
++ Maybe (Doc Any) -> [Doc Any]
forall a. Maybe a -> [a]
maybeToList Maybe (Doc Any)
snippet
          errInGhc :: GhcException
errInGhc = String -> GhcException
GHC.ProgramError (String -> GhcException)
-> (Doc Any -> String) -> Doc Any -> GhcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> GhcException) -> Doc Any -> GhcException
forall a b. (a -> b) -> a -> b
$ Doc Any
msg
      GhcException -> IO a
forall a. GhcException -> IO a
GHC.throwGhcExceptionIO GhcException
errInGhc

getSourceSnippet :: GHC.RealSrcSpan -> IO (Maybe (PP.Doc ann))
getSourceSnippet :: forall ann. RealSrcSpan -> IO (Maybe (Doc ann))
getSourceSnippet RealSrcSpan
ss = do
  let file :: String
file = FastString -> String
GHC.unpackFS (RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
ss)
      sLine :: Int
sLine = RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
ss
      sCol :: Int
sCol = RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
ss
      eLine :: Int
eLine = RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
ss
      eCol :: Int
eCol = RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
ss
  Either SomeException String
result <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (String -> IO String
readFile String
file)
  Maybe (Doc ann) -> IO (Maybe (Doc ann))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Doc ann) -> IO (Maybe (Doc ann)))
-> Maybe (Doc ann) -> IO (Maybe (Doc ann))
forall a b. (a -> b) -> a -> b
$ case Either SomeException String
result of
    Left SomeException
_ -> Maybe (Doc ann)
forall a. Maybe a
Nothing
    Right (String -> [String]
lines -> [String]
ls)
      | Int
sLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
Prelude.&& Int
sLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls ->
          let l :: String
l = [String]
ls [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! (Int
sLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              endCol :: Int
endCol = if Int
eLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sLine then Int
eCol else String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
           in Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Int -> Int -> Int -> String -> Doc ann
forall ann. Int -> Int -> Int -> String -> Doc ann
formatSourceSnippet Int
sLine Int
sCol Int
endCol String
l)
      | Bool
otherwise -> Maybe (Doc ann)
forall a. Maybe a
Nothing

formatSourceSnippet :: Int -> Int -> Int -> String -> PP.Doc ann
formatSourceSnippet :: forall ann. Int -> Int -> Int -> String -> Doc ann
formatSourceSnippet Int
lineNum Int
startCol0 Int
endCol0 String
l0 = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [Doc ann
forall {ann}. Doc ann
preCode, Doc ann
forall {ann}. Doc ann
numberedLine, Doc ann
forall {ann}. Doc ann
postCode]
  where
    (String
l, Int
reduced) = String -> (String, Int)
reduceIndent String
l0
    startCol :: Int
startCol = Int
startCol0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
reduced
    endCol :: Int
endCol = Int
endCol0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
reduced
    k :: Int
k = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
lineNum)
    preCode :: Doc ann
preCode = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
k Char
' ') Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty @String String
" |ᴾᴸᴵᴺᵀᴴ"
    numberedLine :: Doc ann
numberedLine = Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
lineNum Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty @String String
" | " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty String
l
    carets :: String
carets = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startCol)) Char
'^'
    postCode :: Doc ann
postCode =
      String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
k Char
' ')
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty @String String
" | "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
startCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ')
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
red (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty String
carets)
    reduceIndent :: String -> (String, Int)
    reduceIndent :: String -> (String, Int)
reduceIndent String
s
      | Int
ind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
5 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest, Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
5)
      | Bool
otherwise = (String
s, Int
0)
      where
        (String
spaces, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
s
        ind :: Int
ind = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
spaces
    red :: PP.Doc ann -> PP.Doc ann
    red :: forall ann. Doc ann -> Doc ann
red Doc ann
doc = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (String
"\ESC[32m" :: String) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
doc Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (String
"\ESC[0m" :: String)

-- | 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 Id
b CoreExpr
rhs -> Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
GHC.NonRec Id
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 [(Id, CoreExpr)]
bindsRhses ->
    [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
GHC.Rec
      ([(Id, CoreExpr)] -> CoreBind)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [(Id, CoreExpr)]
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( [(Id, CoreExpr)]
-> ((Id, CoreExpr)
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
         (Id, CoreExpr))
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [(Id, CoreExpr)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Id, CoreExpr)]
bindsRhses (((Id, CoreExpr)
  -> ReaderT
       PluginCtx
       (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
       (Id, CoreExpr))
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      [(Id, CoreExpr)])
-> ((Id, CoreExpr)
    -> ReaderT
         PluginCtx
         (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
         (Id, CoreExpr))
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [(Id, CoreExpr)]
forall a b. (a -> b) -> a -> b
$ \(Id
b, CoreExpr
rhs) -> do
              CoreExpr
rhs' <- CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
rhs
              (Id, CoreExpr)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Id, CoreExpr)
forall a.
a
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
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 @marker :: a -> CompiledCode a@ function,
where @marker@ can be @plc@ or @plinthc@,
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 the marker 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 the marker 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
  Name
anchorGhcName <- (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
pcAnchorName
  case CoreExpr
expr of
    -- This clause is for the `plc` marker. It can be removed when we remove `plc`.
    GHC.App
      ( GHC.App
          ( GHC.App
              ( GHC.App
                  -- function id
                  -- sometimes GHCi sticks ticks around this for some reason
                  (CoreExpr -> CoreExpr
stripTicks -> (GHC.Var Id
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
== Id -> Name
GHC.idName Id
fid -> String
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprOrDefer (FastString -> String
forall a. Show a => a -> String
show FastString
fs_locStr) Type
codeTy CoreExpr
inner
    GHC.App
      ( GHC.App
          (Name -> CoreExpr -> CoreExpr
stripAnchors Name
anchorGhcName -> (GHC.Var Id
fid))
          (Name -> CoreExpr -> CoreExpr
stripAnchors Name
anchorGhcName -> GHC.Type Type
codeTy)
        )
      -- code to be compiled
      CoreExpr
inner
        | Name
markerName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Name
GHC.idName Id
fid -> String
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprOrDefer String
"" Type
codeTy CoreExpr
inner
    e :: CoreExpr
e@(GHC.Var Id
fid)
      | Name
markerName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Name
GHC.idName Id
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
. String -> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a. String -> Error uni fun a
InvalidMarkerError (String -> Error DefaultUni DefaultFun Ann)
-> (SDoc -> String) -> SDoc -> Error DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> String
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 Id
b CoreExpr
e -> Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
GHC.Lam Id
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 Id
b Type
t [Alt Id]
alts -> do
      CoreExpr
e' <- CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprs CoreExpr
e
      let expAlt :: Alt Id
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Alt Id)
expAlt (GHC.Alt AltCon
a [Id]
bs CoreExpr
rhs) = AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
GHC.Alt AltCon
a [Id]
bs (CoreExpr -> Alt Id)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Alt Id)
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 Id]
alts' <- (Alt Id
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      (Alt Id))
-> [Alt Id]
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     [Alt Id]
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 Id
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     (Alt Id)
expAlt [Alt Id]
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 -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
GHC.Case CoreExpr
e' Id
b Type
t [Alt Id]
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 Id
_) -> 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 :: String
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExprOrDefer String
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 = String
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExpr String
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 :: String
shown = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ WithContext Text (Error uni fun Ann) -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. WithContext Text (Error uni fun Ann) -> Doc ann
PP.pretty (Int
-> WithContext Text (Error uni fun Ann)
-> WithContext Text (Error uni fun Ann)
forall c e. Int -> WithContext c e -> WithContext c e
pruneContext (PluginOptions -> Int
_posContextLevel PluginOptions
opts) (WithContext Text (Error uni fun Ann)
 -> WithContext Text (Error uni fun Ann))
-> WithContext Text (Error uni fun Ann)
-> WithContext Text (Error uni fun Ann)
forall a b. (a -> b) -> a -> b
$ ((Text, Maybe RealSrcSpan) -> Text)
-> CompileError uni fun Ann -> WithContext Text (Error uni fun Ann)
forall c c' e. (c -> c') -> WithContext c e -> WithContext c' e
mapContext (Text, Maybe RealSrcSpan) -> Text
forall a b. (a, b) -> a
fst 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
  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 -> String -> CoreExpr
GHC.mkImpossibleExpr (TyCon -> [Type] -> Type
GHC.mkTyConApp TyCon
tc [Type
codeTy]) String
shown

{-| 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 :: String
-> Type
-> CoreExpr
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     CoreExpr
compileMarkedExpr String
_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 :: String
moduleNameStr =
        DynFlags -> UnitState -> NamePprCtx -> SDoc -> String
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.||)
           , '(PlutusTx.List.!!)
           , 'PlutusTx.AsData.Internal.wrapTail
           , 'PlutusTx.AsData.Internal.wrapUnsafeDataAsConstr
           , 'PlutusTx.AsData.Internal.droppableUnsafeCaseList
           , 'PlutusTx.Function.fix
           , 'PlutusTx.Optimize.Inline.inline
           , 'useToOpaque
           , 'useFromOpaque
           , 'mkNilOpaque
           , 'mkNil
           , 'PlutusTx.Builtins.equalsInteger
           , 'PlutusTx.Plugin.Utils.anchor
           , 'PlutusTx.Plugin.Utils.unsupported
           ]
  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
                , coDatatypeStyle :: DatatypeStyle
coDatatypeStyle =
                    if PluginOptions -> Version
_posPlcTargetVersion PluginOptions
opts Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
PLC.plcVersion110
                      then DatatypeStyle
PIR.ScottEncoding
                      else DatatypeCompilationOpts -> DatatypeStyle
PIR._dcoStyle (DatatypeCompilationOpts -> DatatypeStyle)
-> DatatypeCompilationOpts -> DatatypeStyle
forall a b. (a -> b) -> a -> b
$ PluginOptions -> DatatypeCompilationOpts
_posDatatypes PluginOptions
opts
                , coRemoveTrace :: Bool
coRemoveTrace = PluginOptions -> Bool
_posRemoveTrace PluginOptions
opts
                , coInlineFix :: Bool
coInlineFix = PluginOptions -> Bool
_posInlineFix PluginOptions
opts
                }
          , ccFlags :: DynFlags
ccFlags = DynFlags
flags
          , ccFamInstEnvs :: FamInstEnvs
ccFamInstEnvs = FamInstEnvs
famEnvs
          , ccNameInfo :: NameInfo
ccNameInfo = NameInfo
nameInfo
          , ccScope :: Scope DefaultUni DefaultFun
ccScope = Scope DefaultUni DefaultFun
forall (uni :: * -> *) fun. Scope uni fun
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
          , ccSafeToInline :: Bool
ccSafeToInline = Bool
False
          }
      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
$
      String
-> 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) =>
String
-> PluginOptions
-> CoreExpr
-> m (PIRProgram uni fun, UPLCProgram uni fun)
runCompiler String
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

  Id
builder <- ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Id
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Id
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 Id
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      Id)
-> (Name
    -> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Id)
-> Name
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM Id
-> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Id
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 Id
 -> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Id)
-> (Name -> CoreM Id)
-> Name
-> ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM Id
forall (m :: * -> *). MonadThings m => Name -> m Id
GHC.lookupId (Name
 -> ReaderT
      PluginCtx
      (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
      Id)
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Name
-> ReaderT
     PluginCtx
     (ExceptT (CompileError DefaultUni DefaultFun Ann) CoreM)
     Id
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
$
    Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
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) =>
String
-> PluginOptions
-> CoreExpr
-> m (PIRProgram uni fun, UPLCProgram uni fun)
runCompiler String
moduleName PluginOptions
opts CoreExpr
expr = do
  GHC.DynFlags {extensions :: DynFlags -> [OnOff Extension]
GHC.extensions = [OnOff Extension]
extensions} <- (CompileContext DefaultUni DefaultFun -> DynFlags) -> m DynFlags
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompileContext DefaultUni DefaultFun -> DynFlags
forall (uni :: * -> *) fun. CompileContext uni fun -> DynFlags
ccFlags
  let
    enabledExtensions :: [Extension]
enabledExtensions =
      (OnOff Extension -> Maybe Extension)
-> [OnOff Extension] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \case
            GHC.On Extension
a -> Extension -> Maybe Extension
forall a. a -> Maybe a
Just Extension
a
            GHC.Off Extension
_ -> Maybe Extension
forall a. Maybe a
Nothing
        )
        [OnOff Extension]
extensions
    extensionBlacklist :: [Extension]
extensionBlacklist =
      [ Extension
GADTs
      , Extension
PolyKinds
      ]
    unsupportedExtensions :: [Extension]
unsupportedExtensions =
      (Extension -> Bool) -> [Extension] -> [Extension]
forall a. (a -> Bool) -> [a] -> [a]
filter (Extension -> [Extension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
extensionBlacklist) [Extension]
enabledExtensions

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Extension] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Extension]
unsupportedExtensions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Error DefaultUni DefaultFun Ann -> m ()
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun Ann -> m ())
-> Error DefaultUni DefaultFun Ann -> m ()
forall a b. (a -> b) -> a -> b
$
      Text -> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (Text -> Error DefaultUni DefaultFun Ann)
-> Text -> Error DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$
        Text
"Following extensions are not supported: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (String -> Text
Text.pack (String -> Text) -> (Extension -> String) -> Extension -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall a. Show a => a -> String
show (Extension -> Text) -> [Extension] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Extension]
unsupportedExtensions)

  -- Plc configuration
  TypeCheckConfig DefaultUni DefaultFun
plcTcConfig <-
    (TypeError
   (Term TyName Name DefaultUni DefaultFun ())
   DefaultUni
   DefaultFun
   (Provenance Ann)
 -> CompileError DefaultUni DefaultFun Ann)
-> ExceptT
     (TypeError
        (Term TyName Name DefaultUni DefaultFun ())
        DefaultUni
        DefaultFun
        (Provenance Ann))
     m
     (TypeCheckConfig DefaultUni DefaultFun)
-> m (TypeCheckConfig DefaultUni DefaultFun)
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError (Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall c e. e -> WithContext c e
NoContext (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> (TypeError
      (Term TyName Name DefaultUni DefaultFun ())
      DefaultUni
      DefaultFun
      (Provenance Ann)
    -> Error DefaultUni DefaultFun Ann)
-> TypeError
     (Term TyName Name DefaultUni DefaultFun ())
     DefaultUni
     DefaultFun
     (Provenance Ann)
-> CompileError DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun (Provenance Ann)
-> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a.
Error uni fun (Provenance a) -> Error uni fun a
PIRError (Error DefaultUni DefaultFun (Provenance Ann)
 -> Error DefaultUni DefaultFun Ann)
-> (TypeError
      (Term TyName Name DefaultUni DefaultFun ())
      DefaultUni
      DefaultFun
      (Provenance Ann)
    -> Error DefaultUni DefaultFun (Provenance Ann))
-> TypeError
     (Term TyName Name DefaultUni DefaultFun ())
     DefaultUni
     DefaultFun
     (Provenance Ann)
-> Error DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError
  (Term TyName Name DefaultUni DefaultFun ())
  DefaultUni
  DefaultFun
  (Provenance Ann)
-> Error DefaultUni DefaultFun (Provenance Ann)
forall (uni :: * -> *) fun a.
TypeError (Term TyName Name uni fun ()) uni fun a
-> Error uni fun a
PIR.PLCTypeError) (ExceptT
   (TypeError
      (Term TyName Name DefaultUni DefaultFun ())
      DefaultUni
      DefaultFun
      (Provenance Ann))
   m
   (TypeCheckConfig DefaultUni DefaultFun)
 -> m (TypeCheckConfig DefaultUni DefaultFun))
-> ExceptT
     (TypeError
        (Term TyName Name DefaultUni DefaultFun ())
        DefaultUni
        DefaultFun
        (Provenance Ann))
     m
     (TypeCheckConfig DefaultUni DefaultFun)
-> m (TypeCheckConfig DefaultUni DefaultFun)
forall a b. (a -> b) -> a -> b
$
      Provenance Ann
-> ExceptT
     (TypeError
        (Term TyName Name DefaultUni DefaultFun ())
        DefaultUni
        DefaultFun
        (Provenance Ann))
     m
     (TypeCheckConfig DefaultUni DefaultFun)
forall term (uni :: * -> *) fun ann (m :: * -> *).
(MonadKindCheck (TypeError term uni fun ann) term uni fun ann m,
 Typecheckable uni fun) =>
ann -> m (TypeCheckConfig uni fun)
PLC.getDefTypeCheckConfig Provenance Ann
forall a. Provenance a
PIR.noProvenance
  DatatypeStyle
datatypeStyle <- (CompileContext DefaultUni DefaultFun -> DatatypeStyle)
-> m DatatypeStyle
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((CompileContext DefaultUni DefaultFun -> DatatypeStyle)
 -> m DatatypeStyle)
-> (CompileContext DefaultUni DefaultFun -> DatatypeStyle)
-> m DatatypeStyle
forall a b. (a -> b) -> a -> b
$ CompileOptions -> DatatypeStyle
coDatatypeStyle (CompileOptions -> DatatypeStyle)
-> (CompileContext DefaultUni DefaultFun -> CompileOptions)
-> CompileContext DefaultUni DefaultFun
-> DatatypeStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileContext DefaultUni DefaultFun -> CompileOptions
forall (uni :: * -> *) fun.
CompileContext uni fun -> CompileOptions
ccOpts
  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
      hints :: InlineHints name (Provenance Ann)
hints = (Provenance Ann -> name -> Inline)
-> InlineHints name (Provenance Ann)
forall name a. (a -> name -> Inline) -> InlineHints name a
UPLC.InlineHints ((Provenance Ann -> name -> Inline)
 -> InlineHints name (Provenance Ann))
-> (Provenance Ann -> name -> Inline)
-> 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
_ -> Inline
AlwaysInline
        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) -> Inline
AlwaysInline
          | Inline
SafeToInline 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) -> Inline
SafeToInline
          | Bool
otherwise -> Inline
MayInline

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

  -- Compilation configuration
  -- pir's tc-config is based on plc tcconfig
  let pirTcConfig :: PirTCConfig DefaultUni DefaultFun
pirTcConfig = TypeCheckConfig DefaultUni DefaultFun
-> AllowEscape -> PirTCConfig DefaultUni DefaultFun
forall (uni :: * -> *) fun.
TypeCheckConfig uni fun -> AllowEscape -> PirTCConfig uni fun
PIR.PirTCConfig TypeCheckConfig DefaultUni DefaultFun
plcTcConfig AllowEscape
PIR.YesEscape
      pirCtx :: CompilationCtx DefaultUni DefaultFun Ann
pirCtx =
        TypeCheckConfig DefaultUni DefaultFun
-> CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun
plcTcConfig
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Int
  Int
-> Int
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Int -> Identity Int)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (PirTCConfig DefaultUni DefaultFun)
  (PirTCConfig DefaultUni DefaultFun)
-> PirTCConfig DefaultUni DefaultFun
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (PirTCConfig DefaultUni DefaultFun)
  (PirTCConfig DefaultUni DefaultFun)
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 DefaultUni DefaultFun
pirTcConfig
          -- Simplifier options
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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.coInlineFix)
            (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posInlineFix)
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (InlineHints Name (Provenance Ann))
  (InlineHints Name (Provenance Ann))
-> InlineHints Name (Provenance Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((InlineHints Name (Provenance Ann)
     -> Identity (InlineHints Name (Provenance Ann)))
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  AstSize
  AstSize
-> AstSize
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((AstSize -> Identity AstSize)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun Ann)
     AstSize
     AstSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AstSize -> Identity AstSize)
-> CompilationOpts Ann -> Identity (CompilationOpts Ann)
forall a (f :: * -> *).
Functor f =>
(AstSize -> f AstSize)
-> CompilationOpts a -> f (CompilationOpts a)
PIR.coInlineCallsiteGrowth)
            (PluginOptions
opts PluginOptions -> Getting AstSize PluginOptions AstSize -> AstSize
forall s a. s -> Getting a s a -> a
^. (Int -> Const AstSize Int)
-> PluginOptions -> Const AstSize PluginOptions
Lens' PluginOptions Int
posInlineCallsiteGrowth ((Int -> Const AstSize Int)
 -> PluginOptions -> Const AstSize PluginOptions)
-> ((AstSize -> Const AstSize AstSize) -> Int -> Const AstSize Int)
-> Getting AstSize PluginOptions AstSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> AstSize)
-> (AstSize -> Const AstSize AstSize) -> Int -> Const AstSize Int
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Int -> AstSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  Bool
  Bool
-> Bool
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((Bool -> Identity Bool)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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)
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  DatatypeStyle
  DatatypeStyle
-> DatatypeStyle
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ((CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> Identity (CompilationCtx DefaultUni DefaultFun 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 DefaultUni DefaultFun Ann
 -> Identity (CompilationCtx DefaultUni DefaultFun Ann))
-> ((DatatypeStyle -> Identity DatatypeStyle)
    -> CompilationOpts Ann -> Identity (CompilationOpts Ann))
-> ASetter
     (CompilationCtx DefaultUni DefaultFun Ann)
     (CompilationCtx DefaultUni DefaultFun 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) DatatypeStyle
datatypeStyle
          -- TODO: ensure the same as the one used in the plugin
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (BuiltinsInfo DefaultUni DefaultFun)
  (BuiltinsInfo DefaultUni DefaultFun)
-> BuiltinsInfo DefaultUni DefaultFun
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (BuiltinsInfo DefaultUni DefaultFun)
  (BuiltinsInfo DefaultUni DefaultFun)
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 DefaultUni DefaultFun
forall a. Default a => a
def
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CostingPart DefaultUni DefaultFun)
  (CostingPart DefaultUni DefaultFun)
-> CostingPart DefaultUni DefaultFun
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CostingPart DefaultUni DefaultFun)
  (CostingPart DefaultUni DefaultFun)
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 CostingPart DefaultUni DefaultFun
forall a. Default a => a
def
          CompilationCtx DefaultUni DefaultFun Ann
-> (CompilationCtx DefaultUni DefaultFun Ann
    -> CompilationCtx DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (RewriteRules DefaultUni DefaultFun)
  (RewriteRules DefaultUni DefaultFun)
-> RewriteRules DefaultUni DefaultFun
-> CompilationCtx DefaultUni DefaultFun Ann
-> CompilationCtx DefaultUni DefaultFun Ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (CompilationCtx DefaultUni DefaultFun Ann)
  (CompilationCtx DefaultUni DefaultFun Ann)
  (RewriteRules DefaultUni DefaultFun)
  (RewriteRules DefaultUni DefaultFun)
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 DefaultUni DefaultFun
rewriteRules
      plcOpts :: CompilationOpts name2 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)
  CseWhichSubterms
  CseWhichSubterms
-> CseWhichSubterms
-> 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))
-> ((CseWhichSubterms -> Identity CseWhichSubterms)
    -> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any))
-> ASetter
     (CompilationOpts Any DefaultFun Any)
     (CompilationOpts Any DefaultFun Any)
     CseWhichSubterms
     CseWhichSubterms
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CseWhichSubterms -> Identity CseWhichSubterms)
-> SimplifyOpts Any Any -> Identity (SimplifyOpts Any Any)
forall name a (f :: * -> *).
Functor f =>
(CseWhichSubterms -> f CseWhichSubterms)
-> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soCseWhichSubterms)
            (PluginOptions
opts PluginOptions
-> Getting CseWhichSubterms PluginOptions CseWhichSubterms
-> CseWhichSubterms
forall s a. s -> Getting a s a -> a
^. Getting CseWhichSubterms PluginOptions CseWhichSubterms
Lens' PluginOptions CseWhichSubterms
posCseWhichSubterms)
          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 name2 DefaultFun (Provenance Ann))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts Any DefaultFun Any)
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  (InlineHints Any Any)
  (InlineHints name2 (Provenance Ann))
-> InlineHints name2 (Provenance Ann)
-> CompilationOpts Any DefaultFun Any
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SimplifyOpts Any Any
 -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> CompilationOpts Any DefaultFun Any
-> Identity (CompilationOpts name2 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 name2 (Provenance Ann)))
 -> CompilationOpts Any DefaultFun Any
 -> Identity (CompilationOpts name2 DefaultFun (Provenance Ann)))
-> ((InlineHints Any Any
     -> Identity (InlineHints name2 (Provenance Ann)))
    -> SimplifyOpts Any Any
    -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> ASetter
     (CompilationOpts Any DefaultFun Any)
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     (InlineHints Any Any)
     (InlineHints name2 (Provenance Ann))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InlineHints Any Any
 -> Identity (InlineHints name2 (Provenance Ann)))
-> SimplifyOpts Any Any
-> Identity (SimplifyOpts name2 (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 name2 (Provenance Ann)
forall {name}. InlineHints name (Provenance Ann)
hints
          CompilationOpts name2 DefaultFun (Provenance Ann)
-> (CompilationOpts name2 DefaultFun (Provenance Ann)
    -> CompilationOpts name2 DefaultFun (Provenance Ann))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  Bool
  Bool
-> Bool
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((SimplifyOpts name2 (Provenance Ann)
 -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> Identity (CompilationOpts name2 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 name2 (Provenance Ann)
  -> Identity (SimplifyOpts name2 (Provenance Ann)))
 -> CompilationOpts name2 DefaultFun (Provenance Ann)
 -> Identity (CompilationOpts name2 DefaultFun (Provenance Ann)))
-> ((Bool -> Identity Bool)
    -> SimplifyOpts name2 (Provenance Ann)
    -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> ASetter
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     Bool
     Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> SimplifyOpts name2 (Provenance Ann)
-> Identity (SimplifyOpts name2 (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)
          CompilationOpts name2 DefaultFun (Provenance Ann)
-> (CompilationOpts name2 DefaultFun (Provenance Ann)
    -> CompilationOpts name2 DefaultFun (Provenance Ann))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  AstSize
  AstSize
-> AstSize
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((SimplifyOpts name2 (Provenance Ann)
 -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> Identity (CompilationOpts name2 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 name2 (Provenance Ann)
  -> Identity (SimplifyOpts name2 (Provenance Ann)))
 -> CompilationOpts name2 DefaultFun (Provenance Ann)
 -> Identity (CompilationOpts name2 DefaultFun (Provenance Ann)))
-> ((AstSize -> Identity AstSize)
    -> SimplifyOpts name2 (Provenance Ann)
    -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> ASetter
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     AstSize
     AstSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AstSize -> Identity AstSize)
-> SimplifyOpts name2 (Provenance Ann)
-> Identity (SimplifyOpts name2 (Provenance Ann))
forall name a (f :: * -> *).
Functor f =>
(AstSize -> f AstSize)
-> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soInlineCallsiteGrowth)
            (PluginOptions
opts PluginOptions -> Getting AstSize PluginOptions AstSize -> AstSize
forall s a. s -> Getting a s a -> a
^. (Int -> Const AstSize Int)
-> PluginOptions -> Const AstSize PluginOptions
Lens' PluginOptions Int
posInlineCallsiteGrowth ((Int -> Const AstSize Int)
 -> PluginOptions -> Const AstSize PluginOptions)
-> ((AstSize -> Const AstSize AstSize) -> Int -> Const AstSize Int)
-> Getting AstSize PluginOptions AstSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> AstSize)
-> (AstSize -> Const AstSize AstSize) -> Int -> Const AstSize Int
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Int -> AstSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
          CompilationOpts name2 DefaultFun (Provenance Ann)
-> (CompilationOpts name2 DefaultFun (Provenance Ann)
    -> CompilationOpts name2 DefaultFun (Provenance Ann))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  Bool
  Bool
-> Bool
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((SimplifyOpts name2 (Provenance Ann)
 -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> Identity (CompilationOpts name2 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 name2 (Provenance Ann)
  -> Identity (SimplifyOpts name2 (Provenance Ann)))
 -> CompilationOpts name2 DefaultFun (Provenance Ann)
 -> Identity (CompilationOpts name2 DefaultFun (Provenance Ann)))
-> ((Bool -> Identity Bool)
    -> SimplifyOpts name2 (Provenance Ann)
    -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> ASetter
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     Bool
     Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> SimplifyOpts name2 (Provenance Ann)
-> Identity (SimplifyOpts name2 (Provenance Ann))
forall name a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soPreserveLogging)
            (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)
          CompilationOpts name2 DefaultFun (Provenance Ann)
-> (CompilationOpts name2 DefaultFun (Provenance Ann)
    -> CompilationOpts name2 DefaultFun (Provenance Ann))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall a b. a -> (a -> b) -> b
& ASetter
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  (CompilationOpts name2 DefaultFun (Provenance Ann))
  Bool
  Bool
-> Bool
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> CompilationOpts name2 DefaultFun (Provenance Ann)
forall s t a b. ASetter s t a b -> b -> s -> t
set
            ((SimplifyOpts name2 (Provenance Ann)
 -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> CompilationOpts name2 DefaultFun (Provenance Ann)
-> Identity (CompilationOpts name2 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 name2 (Provenance Ann)
  -> Identity (SimplifyOpts name2 (Provenance Ann)))
 -> CompilationOpts name2 DefaultFun (Provenance Ann)
 -> Identity (CompilationOpts name2 DefaultFun (Provenance Ann)))
-> ((Bool -> Identity Bool)
    -> SimplifyOpts name2 (Provenance Ann)
    -> Identity (SimplifyOpts name2 (Provenance Ann)))
-> ASetter
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     (CompilationOpts name2 DefaultFun (Provenance Ann))
     Bool
     Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> SimplifyOpts name2 (Provenance Ann)
-> Identity (SimplifyOpts name2 (Provenance Ann))
forall name a (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> SimplifyOpts name a -> f (SimplifyOpts name a)
UPLC.soApplyToCase)
            (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posApplyToCase)

  -- GHC.Core -> Pir translation.
  Term TyName Name DefaultUni DefaultFun (Provenance Ann)
pirT <- Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun (Provenance Ann)
forall (f :: * -> *) a. Functor f => f a -> f (Provenance a)
original (Term TyName Name DefaultUni DefaultFun Ann
 -> Term TyName Name DefaultUni DefaultFun (Provenance Ann))
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun (Provenance Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ann
-> DefT
     LexName
     DefaultUni
     DefaultFun
     Ann
     m
     (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun 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
forall a. AnnInline a => a
annMayInline (DefT
   LexName
   DefaultUni
   DefaultFun
   Ann
   m
   (Term TyName Name DefaultUni DefaultFun Ann)
 -> m (Term TyName Name DefaultUni DefaultFun Ann))
-> DefT
     LexName
     DefaultUni
     DefaultFun
     Ann
     m
     (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$ CoreExpr
-> DefT
     LexName
     DefaultUni
     DefaultFun
     Ann
     m
     (Term TyName Name DefaultUni DefaultFun Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExprWithDefs CoreExpr
expr)
  let pirP :: Program TyName Name DefaultUni DefaultFun (Provenance Ann)
pirP = Provenance Ann
-> Version
-> Term TyName Name DefaultUni DefaultFun (Provenance Ann)
-> Program TyName Name DefaultUni DefaultFun (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 DefaultUni DefaultFun (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 DefaultUni DefaultFun ()
-> String -> String -> IO ()
forall t. Flat t => t -> String -> String -> IO ()
dumpFlat (Program TyName Name DefaultUni DefaultFun (Provenance Ann)
-> Program TyName Name DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program TyName Name DefaultUni DefaultFun (Provenance Ann)
pirP) String
"initial PIR program" (String
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_initial.pir-flat")

  -- Pir -> (Simplified) Pir pass. We can then dump/store a more legible PIR program.
  Program TyName Name DefaultUni DefaultFun (Provenance Ann)
spirP <-
    (ReaderT
   (CompilationCtx DefaultUni DefaultFun Ann)
   m
   (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
 -> CompilationCtx DefaultUni DefaultFun Ann
 -> m (Program TyName Name DefaultUni DefaultFun (Provenance Ann)))
-> CompilationCtx DefaultUni DefaultFun Ann
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
-> m (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompilationCtx DefaultUni DefaultFun Ann)
  m
  (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> m (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationCtx DefaultUni DefaultFun Ann
pirCtx (ReaderT
   (CompilationCtx DefaultUni DefaultFun Ann)
   m
   (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
 -> m (Program TyName Name DefaultUni DefaultFun (Provenance Ann)))
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
-> m (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$
      (Error DefaultUni DefaultFun (Provenance Ann)
 -> CompileError DefaultUni DefaultFun Ann)
-> ExceptT
     (Error DefaultUni DefaultFun (Provenance Ann))
     (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError (Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall c e. e -> WithContext c e
NoContext (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> (Error DefaultUni DefaultFun (Provenance Ann)
    -> Error DefaultUni DefaultFun Ann)
-> Error DefaultUni DefaultFun (Provenance Ann)
-> CompileError DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun (Provenance Ann)
-> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a.
Error uni fun (Provenance a) -> Error uni fun a
PIRError) (ExceptT
   (Error DefaultUni DefaultFun (Provenance Ann))
   (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
   (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
 -> ReaderT
      (CompilationCtx DefaultUni DefaultFun Ann)
      m
      (Program TyName Name DefaultUni DefaultFun (Provenance Ann)))
-> ExceptT
     (Error DefaultUni DefaultFun (Provenance Ann))
     (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$
        Program TyName Name DefaultUni DefaultFun (Provenance Ann)
-> ExceptT
     (Error DefaultUni DefaultFun (Provenance Ann))
     (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
     (Program TyName Name DefaultUni DefaultFun (Provenance Ann))
forall (m :: * -> *) (uni :: * -> *) fun a b.
(Compiling m uni fun a, b ~ Provenance a) =>
Program TyName Name uni fun b -> m (Program TyName Name uni fun b)
PIR.compileToReadable Program TyName Name DefaultUni DefaultFun (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 DefaultUni DefaultFun ()
-> String -> String -> IO ()
forall t. Flat t => t -> String -> String -> IO ()
dumpFlat (Program TyName Name DefaultUni DefaultFun (Provenance Ann)
-> Program TyName Name DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program TyName Name DefaultUni DefaultFun (Provenance Ann)
spirP) String
"simplified PIR program" (String
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_simplified.pir-flat")

  -- (Simplified) Pir -> Plc translation.
  PLCProgram DefaultUni DefaultFun Ann
plcP <-
    (ReaderT
   (CompilationCtx DefaultUni DefaultFun Ann)
   m
   (PLCProgram DefaultUni DefaultFun Ann)
 -> CompilationCtx DefaultUni DefaultFun Ann
 -> m (PLCProgram DefaultUni DefaultFun Ann))
-> CompilationCtx DefaultUni DefaultFun Ann
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (PLCProgram DefaultUni DefaultFun Ann)
-> m (PLCProgram DefaultUni DefaultFun Ann)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompilationCtx DefaultUni DefaultFun Ann)
  m
  (PLCProgram DefaultUni DefaultFun Ann)
-> CompilationCtx DefaultUni DefaultFun Ann
-> m (PLCProgram DefaultUni DefaultFun Ann)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationCtx DefaultUni DefaultFun Ann
pirCtx (ReaderT
   (CompilationCtx DefaultUni DefaultFun Ann)
   m
   (PLCProgram DefaultUni DefaultFun Ann)
 -> m (PLCProgram DefaultUni DefaultFun Ann))
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (PLCProgram DefaultUni DefaultFun Ann)
-> m (PLCProgram DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$
      (Error DefaultUni DefaultFun (Provenance Ann)
 -> CompileError DefaultUni DefaultFun Ann)
-> ExceptT
     (Error DefaultUni DefaultFun (Provenance Ann))
     (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
     (PLCProgram DefaultUni DefaultFun Ann)
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (PLCProgram DefaultUni DefaultFun Ann)
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError (Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall c e. e -> WithContext c e
NoContext (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> (Error DefaultUni DefaultFun (Provenance Ann)
    -> Error DefaultUni DefaultFun Ann)
-> Error DefaultUni DefaultFun (Provenance Ann)
-> CompileError DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun (Provenance Ann)
-> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a.
Error uni fun (Provenance a) -> Error uni fun a
PIRError) (ExceptT
   (Error DefaultUni DefaultFun (Provenance Ann))
   (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
   (PLCProgram DefaultUni DefaultFun Ann)
 -> ReaderT
      (CompilationCtx DefaultUni DefaultFun Ann)
      m
      (PLCProgram DefaultUni DefaultFun Ann))
-> ExceptT
     (Error DefaultUni DefaultFun (Provenance Ann))
     (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
     (PLCProgram DefaultUni DefaultFun Ann)
-> ReaderT
     (CompilationCtx DefaultUni DefaultFun Ann)
     m
     (PLCProgram DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$
        Program TyName Name DefaultUni DefaultFun (Provenance Ann)
-> ExceptT
     (Error DefaultUni DefaultFun (Provenance Ann))
     (ReaderT (CompilationCtx DefaultUni DefaultFun Ann) m)
     (PLCProgram DefaultUni DefaultFun Ann)
forall (m :: * -> *) (uni :: * -> *) fun a b.
(Compiling m uni fun a, b ~ Provenance a) =>
Program TyName Name uni fun b -> m (PLCProgram uni fun a)
PIR.compileReadableToPlc Program TyName Name DefaultUni DefaultFun (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 DefaultUni DefaultFun ()
-> String -> String -> IO ()
forall t. Flat t => t -> String -> String -> IO ()
dumpFlat (PLCProgram DefaultUni DefaultFun Ann
-> Program TyName Name DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void PLCProgram DefaultUni DefaultFun Ann
plcP) String
"typed PLC program" (String
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".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 DefaultUni ())) -> m ())
-> m (Normalized (Type TyName DefaultUni ()))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Normalized (Type TyName DefaultUni ())) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Normalized (Type TyName DefaultUni ())) -> m ())
-> m (Normalized (Type TyName DefaultUni ())) -> m ()
forall a b. (a -> b) -> a -> b
$
    ExceptT
  (Error DefaultUni DefaultFun Ann)
  m
  (Normalized (Type TyName DefaultUni ()))
-> m (Normalized (Type TyName DefaultUni ()))
forall b. ExceptT (Error DefaultUni DefaultFun Ann) m b -> m b
liftExcept (ExceptT
   (Error DefaultUni DefaultFun Ann)
   m
   (Normalized (Type TyName DefaultUni ()))
 -> m (Normalized (Type TyName DefaultUni ())))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Normalized (Type TyName DefaultUni ()))
-> m (Normalized (Type TyName DefaultUni ()))
forall a b. (a -> b) -> a -> b
$
      (TypeErrorPlc DefaultUni DefaultFun Ann
 -> Error DefaultUni DefaultFun Ann)
-> ExceptT
     (TypeErrorPlc DefaultUni DefaultFun Ann)
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Normalized (Type TyName DefaultUni ()))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Normalized (Type TyName DefaultUni ()))
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError TypeErrorPlc DefaultUni DefaultFun Ann
-> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun ann.
TypeError (Term TyName Name uni fun ()) uni fun ann
-> Error uni fun ann
PLC.TypeErrorE (ExceptT
   (TypeErrorPlc DefaultUni DefaultFun Ann)
   (ExceptT (Error DefaultUni DefaultFun Ann) m)
   (Normalized (Type TyName DefaultUni ()))
 -> ExceptT
      (Error DefaultUni DefaultFun Ann)
      m
      (Normalized (Type TyName DefaultUni ())))
-> ExceptT
     (TypeErrorPlc DefaultUni DefaultFun Ann)
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Normalized (Type TyName DefaultUni ()))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Normalized (Type TyName DefaultUni ()))
forall a b. (a -> b) -> a -> b
$
        TypeCheckConfig DefaultUni DefaultFun
-> Program TyName Name DefaultUni DefaultFun Ann
-> ExceptT
     (TypeErrorPlc DefaultUni DefaultFun Ann)
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Normalized (Type TyName DefaultUni ()))
forall (uni :: * -> *) fun ann (m :: * -> *).
MonadTypeCheckPlc uni fun ann m =>
TypeCheckConfig uni fun
-> Program TyName Name uni fun ann
-> m (Normalized (Type TyName uni ()))
PLC.inferTypeOfProgram TypeCheckConfig DefaultUni DefaultFun
plcTcConfig (PLCProgram DefaultUni DefaultFun Ann
plcP PLCProgram DefaultUni DefaultFun Ann
-> Ann -> Program TyName Name DefaultUni DefaultFun Ann
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ann
forall a. AnnInline a => a
annMayInline)

  let optCertify :: Maybe String
optCertify = PluginOptions
opts PluginOptions
-> Getting (Maybe String) PluginOptions (Maybe String)
-> Maybe String
forall s a. s -> Getting a s a -> a
^. Getting (Maybe String) PluginOptions (Maybe String)
Lens' PluginOptions (Maybe String)
posCertify
  (Program Name DefaultUni DefaultFun (Provenance Ann)
uplcP, SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann)
simplTrace) <- (ReaderT
   (CompilationOpts Name DefaultFun (Provenance Ann))
   m
   (Program Name DefaultUni DefaultFun (Provenance Ann),
    SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
 -> CompilationOpts Name DefaultFun (Provenance Ann)
 -> m (Program Name DefaultUni DefaultFun (Provenance Ann),
       SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann)))
-> CompilationOpts Name DefaultFun (Provenance Ann)
-> ReaderT
     (CompilationOpts Name DefaultFun (Provenance Ann))
     m
     (Program Name DefaultUni DefaultFun (Provenance Ann),
      SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
-> m (Program Name DefaultUni DefaultFun (Provenance Ann),
      SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompilationOpts Name DefaultFun (Provenance Ann))
  m
  (Program Name DefaultUni DefaultFun (Provenance Ann),
   SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
-> CompilationOpts Name DefaultFun (Provenance Ann)
-> m (Program Name DefaultUni DefaultFun (Provenance Ann),
      SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationOpts Name DefaultFun (Provenance Ann)
forall {name2}. CompilationOpts name2 DefaultFun (Provenance Ann)
plcOpts (ReaderT
   (CompilationOpts Name DefaultFun (Provenance Ann))
   m
   (Program Name DefaultUni DefaultFun (Provenance Ann),
    SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
 -> m (Program Name DefaultUni DefaultFun (Provenance Ann),
       SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann)))
-> ReaderT
     (CompilationOpts Name DefaultFun (Provenance Ann))
     m
     (Program Name DefaultUni DefaultFun (Provenance Ann),
      SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
-> m (Program Name DefaultUni DefaultFun (Provenance Ann),
      SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$ PLCProgram DefaultUni DefaultFun Ann
-> ReaderT
     (CompilationOpts Name DefaultFun (Provenance Ann))
     m
     (Program Name DefaultUni DefaultFun (Provenance Ann),
      SimplifierTrace Name DefaultUni DefaultFun (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, SimplifierTrace name uni fun a)
PLC.compileProgramWithTrace PLCProgram DefaultUni DefaultFun Ann
plcP
  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
$ case Maybe String
optCertify of
    Just String
certName -> do
      -- FIXME: add a plugin option to choose from BasicOutput vs. other options
      Either CertifierError Bool
result <- Certifier Bool -> IO (Either CertifierError Bool)
forall a. Certifier a -> IO (Either CertifierError a)
runCertifier (Certifier Bool -> IO (Either CertifierError Bool))
-> Certifier Bool -> IO (Either CertifierError Bool)
forall a b. (a -> b) -> a -> b
$ SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann)
-> String -> CertifierOutput -> Certifier Bool
forall a.
SimplifierTrace Name DefaultUni DefaultFun a
-> String -> CertifierOutput -> Certifier Bool
mkCertifier SimplifierTrace Name DefaultUni DefaultFun (Provenance Ann)
simplTrace String
certName CertifierOutput
BasicOutput
      case Either CertifierError Bool
result of
        Right Bool
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left CertifierError
err ->
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CertifierError -> String
prettyCertifierError CertifierError
err
    Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann)
dbP <-
    ExceptT
  (Error DefaultUni DefaultFun Ann)
  m
  (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
-> m (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
forall b. ExceptT (Error DefaultUni DefaultFun Ann) m b -> m b
liftExcept (ExceptT
   (Error DefaultUni DefaultFun Ann)
   m
   (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
 -> m (Program
         NamedDeBruijn DefaultUni DefaultFun (Provenance Ann)))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
-> m (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$ (FreeVariableError -> Error DefaultUni DefaultFun Ann)
-> ExceptT
     FreeVariableError
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError FreeVariableError -> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun ann.
FreeVariableError -> Error uni fun ann
PLC.FreeVariableErrorE (ExceptT
   FreeVariableError
   (ExceptT (Error DefaultUni DefaultFun Ann) m)
   (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
 -> ExceptT
      (Error DefaultUni DefaultFun Ann)
      m
      (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann)))
-> ExceptT
     FreeVariableError
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
-> ExceptT
     (Error DefaultUni DefaultFun Ann)
     m
     (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
forall a b. (a -> b) -> a -> b
$ LensLike
  (ExceptT
     FreeVariableError (ExceptT (Error DefaultUni DefaultFun Ann) m))
  (Program Name DefaultUni DefaultFun (Provenance Ann))
  (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
  (Term Name DefaultUni DefaultFun (Provenance Ann))
  (Term NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
-> LensLike
     (ExceptT
        FreeVariableError (ExceptT (Error DefaultUni DefaultFun Ann) m))
     (Program Name DefaultUni DefaultFun (Provenance Ann))
     (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
     (Term Name DefaultUni DefaultFun (Provenance Ann))
     (Term NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf LensLike
  (ExceptT
     FreeVariableError (ExceptT (Error DefaultUni DefaultFun Ann) m))
  (Program Name DefaultUni DefaultFun (Provenance Ann))
  (Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
  (Term Name DefaultUni DefaultFun (Provenance Ann))
  (Term NamedDeBruijn DefaultUni DefaultFun (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 DefaultUni DefaultFun (Provenance Ann)
-> ExceptT
     FreeVariableError
     (ExceptT (Error DefaultUni DefaultFun Ann) m)
     (Term NamedDeBruijn DefaultUni DefaultFun (Provenance Ann))
forall (m :: * -> *) (uni :: * -> *) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Program Name DefaultUni DefaultFun (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 DefaultUni DefaultFun ()
-> String -> String -> IO ()
forall t. Flat t => t -> String -> String -> IO ()
dumpFlat
      (Program NamedDeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram (Program NamedDeBruijn DefaultUni DefaultFun ()
 -> UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ())
-> Program NamedDeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann)
-> Program NamedDeBruijn DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program NamedDeBruijn DefaultUni DefaultFun (Provenance Ann)
dbP)
      String
"untyped PLC program"
      (String
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".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)
Program TyName Name DefaultUni DefaultFun (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)
Program NamedDeBruijn DefaultUni DefaultFun (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 = (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> ExceptT (Error DefaultUni DefaultFun Ann) m b -> m b
forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError (Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall c e. e -> WithContext c e
NoContext (Error DefaultUni DefaultFun Ann
 -> CompileError DefaultUni DefaultFun Ann)
-> (Error DefaultUni DefaultFun Ann
    -> Error DefaultUni DefaultFun Ann)
-> Error DefaultUni DefaultFun Ann
-> CompileError DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun Ann -> Error DefaultUni DefaultFun Ann
forall (uni :: * -> *) fun a. Error uni fun a -> Error uni fun a
PLCError)

    dumpFlat :: Flat t => t -> String -> String -> IO ()
    dumpFlat :: forall t. Flat t => t -> String -> String -> IO ()
dumpFlat t
t String
desc String
fileName = do
      (String
tPath, Handle
tHandle) <- String -> String -> IO (String, Handle)
openBinaryTempFile String
"." String
fileName
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"!!! dumping " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
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
  Id
upio <- ExceptT (CompileError uni fun Ann) CoreM Id
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id
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 Id
 -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id)
-> (Name -> ExceptT (CompileError uni fun Ann) CoreM Id)
-> Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM Id -> ExceptT (CompileError uni fun Ann) CoreM Id
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 Id -> ExceptT (CompileError uni fun Ann) CoreM Id)
-> (Name -> CoreM Id)
-> Name
-> ExceptT (CompileError uni fun Ann) CoreM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM Id
forall (m :: * -> *). MonadThings m => Name -> m Id
GHC.lookupId (Name
 -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id
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
  Id
upal <- ExceptT (CompileError uni fun Ann) CoreM Id
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id
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 Id
 -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id)
-> (Name -> ExceptT (CompileError uni fun Ann) CoreM Id)
-> Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM Id -> ExceptT (CompileError uni fun Ann) CoreM Id
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 Id -> ExceptT (CompileError uni fun Ann) CoreM Id)
-> (Name -> CoreM Id)
-> Name
-> ExceptT (CompileError uni fun Ann) CoreM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM Id
forall (m :: * -> *). MonadThings m => Name -> m Id
GHC.lookupId (Name
 -> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id)
-> ReaderT
     PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Name
-> ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) CoreM) Id
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 :: Expr b
bsLit = Literal -> Expr b
forall b. Literal -> Expr b
GHC.Lit (ByteString -> Literal
GHC.LitString ByteString
bs)
  let upaled :: CoreExpr
upaled = CoreExpr -> [CoreExpr] -> CoreExpr
GHC.mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
upal) [CoreExpr
lenLit, CoreExpr
forall {b}. Expr b
bsLit]
  let upioed :: CoreExpr
upioed = CoreExpr -> [CoreExpr] -> CoreExpr
GHC.mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
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

stripAnchors :: GHC.Name -> GHC.CoreExpr -> GHC.CoreExpr
stripAnchors :: Name -> CoreExpr -> CoreExpr
stripAnchors Name
marker = \case
  GHC.Tick CoreTickish
_ CoreExpr
e -> Name -> CoreExpr -> CoreExpr
stripAnchors Name
marker CoreExpr
e
  GHC.App (GHC.App (GHC.App (GHC.Var Id
f) CoreExpr
_locTy) CoreExpr
_codeTy) CoreExpr
code
    | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
marker -> Name -> CoreExpr -> CoreExpr
stripAnchors Name
marker CoreExpr
code
  CoreExpr
other -> CoreExpr
other

-- | 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
    ]