{-# LANGUAGE TemplateHaskellQuotes #-}

module Plinth.Plugin (plugin, plinthc) where

import PlutusTx.Options
import PlutusTx.Plugin.Boilerplate
import PlutusTx.Plugin.Common
import PlutusTx.Plugin.Timing
import PlutusTx.Plugin.Unsupported
import PlutusTx.Plugin.Utils

import Control.Exception (throwIO)
import Control.Lens ((^.))
import Control.Monad.IO.Class (liftIO)
import Data.Either.Validation
import GHC.LanguageExtensions qualified as GHC
import GHC.Plugins qualified as GHC
import GHC.Tc.Types qualified as GHC
import GHC.Utils.Logger qualified as GHC

plugin :: GHC.Plugin
plugin :: Plugin
plugin =
  Plugin
GHC.defaultPlugin
    { GHC.driverPlugin = \[CommandLineOption]
cliOpts HscEnv
environment -> do
        PluginOptions
opts <- case [CommandLineOption] -> Validation ParseErrors PluginOptions
parsePluginOptions ([CommandLineOption] -> [CommandLineOption]
removeBoilerplateOpts [CommandLineOption]
cliOpts) of
          Success PluginOptions
parsed -> PluginOptions -> IO PluginOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PluginOptions
parsed
          Failure ParseErrors
errs -> ParseErrors -> IO PluginOptions
forall e a. Exception e => e -> IO a
throwIO ParseErrors
errs
        Logger
-> Bool
-> CommandLineOption
-> CommandLineOption
-> (HscEnv -> ())
-> IO HscEnv
-> IO HscEnv
forall (monad :: * -> *) result.
MonadIO monad =>
Logger
-> Bool
-> CommandLineOption
-> CommandLineOption
-> (result -> ())
-> monad result
-> monad result
timeStage
          (HscEnv -> Logger
GHC.hsc_logger HscEnv
environment)
          (PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posForceTimings)
          CommandLineOption
"<driver>"
          CommandLineOption
"source.driver"
          ( \HscEnv
result ->
              Extension -> DynFlags -> Bool
GHC.xopt Extension
GHC.Strict (HscEnv -> DynFlags
GHC.hsc_dflags HscEnv
result) Bool -> () -> ()
forall a b. a -> b -> b
`seq`
                GeneralFlag -> DynFlags -> Bool
GHC.gopt GeneralFlag
GHC.Opt_Strictness (HscEnv -> DynFlags
GHC.hsc_dflags HscEnv
result) Bool -> () -> ()
forall a b. a -> b -> b
`seq`
                  ()
          )
          ([CommandLineOption] -> HscEnv -> IO HscEnv
addFlagsAndExts [CommandLineOption]
cliOpts HscEnv
environment)
    , GHC.typeCheckResultAction = \[CommandLineOption]
cliOpts ModSummary
_modSummary TcGblEnv
env -> do
        PluginOptions
opts <- case [CommandLineOption] -> Validation ParseErrors PluginOptions
parsePluginOptions ([CommandLineOption] -> [CommandLineOption]
removeBoilerplateOpts [CommandLineOption]
cliOpts) of
          Success PluginOptions
o -> PluginOptions -> IOEnv (Env TcGblEnv TcLclEnv) PluginOptions
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PluginOptions
o
          Failure ParseErrors
errs -> IO PluginOptions -> IOEnv (Env TcGblEnv TcLclEnv) PluginOptions
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PluginOptions -> IOEnv (Env TcGblEnv TcLclEnv) PluginOptions)
-> IO PluginOptions -> IOEnv (Env TcGblEnv TcLclEnv) PluginOptions
forall a b. (a -> b) -> a -> b
$ ParseErrors -> IO PluginOptions
forall e a. Exception e => e -> IO a
throwIO ParseErrors
errs
        Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
GHC.getLogger
        let forceResults :: Bool
forceResults = PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posForceTimings
            scope :: CommandLineOption
scope = ModuleName -> CommandLineOption
GHC.moduleNameString (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (TcGblEnv -> GenModule Unit
GHC.tcg_mod TcGblEnv
env))
            measure :: CommandLineOption -> monad result -> monad result
measure CommandLineOption
stage = Logger
-> Bool
-> CommandLineOption
-> CommandLineOption
-> (result -> ())
-> monad result
-> monad result
forall (monad :: * -> *) result.
MonadIO monad =>
Logger
-> Bool
-> CommandLineOption
-> CommandLineOption
-> (result -> ())
-> monad result
-> monad result
timeStage Logger
logger Bool
forceResults CommandLineOption
scope CommandLineOption
stage (() -> result -> ()
forall a b. a -> b -> a
const ())
            maybeInjectAnchors :: TcGblEnv -> TcM TcGblEnv
maybeInjectAnchors =
              if PluginOptions
opts PluginOptions -> Getting Bool PluginOptions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool PluginOptions Bool
Lens' PluginOptions Bool
posPreserveSourceLocations then TcGblEnv -> TcM TcGblEnv
injectAnchors else TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        CommandLineOption -> TcM TcGblEnv -> TcM TcGblEnv
forall {monad :: * -> *} {result}.
MonadIO monad =>
CommandLineOption -> monad result -> monad result
measure CommandLineOption
"source.total" (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
          TcGblEnv
anchored <- CommandLineOption -> TcM TcGblEnv -> TcM TcGblEnv
forall {monad :: * -> *} {result}.
MonadIO monad =>
CommandLineOption -> monad result -> monad result
measure CommandLineOption
"source.anchors" (TcGblEnv -> TcM TcGblEnv
maybeInjectAnchors TcGblEnv
env)
          TcGblEnv
supported <- CommandLineOption -> TcM TcGblEnv -> TcM TcGblEnv
forall {monad :: * -> *} {result}.
MonadIO monad =>
CommandLineOption -> monad result -> monad result
measure CommandLineOption
"source.unsupported-markers" (TcGblEnv -> TcM TcGblEnv
injectUnsupportedMarkers TcGblEnv
anchored)
          CommandLineOption -> TcM TcGblEnv -> TcM TcGblEnv
forall {monad :: * -> *} {result}.
MonadIO monad =>
CommandLineOption -> monad result -> monad result
measure CommandLineOption
"source.inlineable-pragmas" (TcGblEnv -> TcM TcGblEnv
addInlineables TcGblEnv
supported)
    , GHC.pluginRecompile = GHC.flagRecompile
    , GHC.installCoreToDos = installCorePlugin 'plinthc
    }