{-# LANGUAGE TemplateHaskellQuotes #-}

module Plinth.Plugin (plugin, plinthc) where

import PlutusTx.Options
import PlutusTx.Plugin.Boilerplate
import PlutusTx.Plugin.Common
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.Plugins qualified as GHC

plugin :: GHC.Plugin
plugin :: Plugin
plugin =
  Plugin
GHC.defaultPlugin
    { GHC.driverPlugin = addFlagsAndExts
    , 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
        let 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
        TcGblEnv -> TcM TcGblEnv
maybeInjectAnchors TcGblEnv
env TcM TcGblEnv -> (TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TcGblEnv -> TcM TcGblEnv
injectUnsupportedMarkers TcM TcGblEnv -> (TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TcGblEnv -> TcM TcGblEnv
addInlineables
    , GHC.pluginRecompile = GHC.flagRecompile
    , GHC.installCoreToDos = installCorePlugin 'plinthc
    }