{- |
Module      : Henforcer
Description :
Copyright   : (c) Flipstone Technology Partners, 2023-2026
License     : MIT
Maintainer  : maintainers@flipstone.com
-}
module Henforcer
  ( plugin
  ) where

import qualified Control.Concurrent.MVar as MVar
import qualified Pollock
import qualified System.IO.Unsafe as UnsafeIO

import qualified CompatGHC
import qualified Henforcer.Checks as Checks
import qualified Henforcer.Config as Config
import qualified Henforcer.Options as Options

plugin :: CompatGHC.Plugin
plugin :: Plugin
plugin =
  Plugin
CompatGHC.defaultPlugin
    { CompatGHC.pluginRecompile = recompile
    , CompatGHC.renamedResultAction = CompatGHC.keepRenamedSource
    , CompatGHC.typeCheckResultAction = typeCheckResultAction
    , CompatGHC.driverPlugin = Pollock.ensureHaddockIsOn
    }

-- Using an MVar and unsafePerformIO here is a very ugly hack, but the plugin interface gives us no
-- way to load the configuration once for the entire set of modules being compiled. This is a big
-- enough performance win that the cost seems likely worth it otherwise.
globalConfigState :: MVar.MVar (Config.Config, CompatGHC.Fingerprint)
{-# NOINLINE globalConfigState #-}
globalConfigState :: MVar (Config, Fingerprint)
globalConfigState = IO (MVar (Config, Fingerprint)) -> MVar (Config, Fingerprint)
forall a. IO a -> a
UnsafeIO.unsafePerformIO IO (MVar (Config, Fingerprint))
forall a. IO (MVar a)
MVar.newEmptyMVar

{- | During typechecking is when Henforcer performs checks, adding any violations to the error
messages tracked by GHC.
-}
typeCheckResultAction ::
  [CompatGHC.CommandLineOption]
  -> CompatGHC.ModSummary
  -> CompatGHC.TcGblEnv
  -> CompatGHC.TcM CompatGHC.TcGblEnv
typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction [CommandLineOption]
commandLineOpts ModSummary
_modSummary TcGblEnv
tcGblEnv = do
  config <- IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
CompatGHC.liftIO (IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config)
-> IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config
forall a b. (a -> b) -> a -> b
$ [CommandLineOption] -> IO Config
loadConfigIfNeeded [CommandLineOption]
commandLineOpts
  let
    modName = GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
CompatGHC.moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> GenModule Unit
CompatGHC.tcg_mod TcGblEnv
tcGblEnv

  CompatGHC.addMessages
    . Checks.errorMessagesFromList
    $ Checks.checkImports (Checks.determineChecks config modName) tcGblEnv

  pollockModuleInfo <- CompatGHC.liftIO $ Pollock.processModule tcGblEnv

  CompatGHC.addMessages
    . Checks.docErrorMessagesFromList
    $ Checks.checkDocumentation (Checks.determineDocumentationChecks config modName) pollockModuleInfo

  pure tcGblEnv

{- | Determines if recompilation of previous modules should happen. This always gets the fingerprint
of the configuration so that a cached version does not conflict with the recompilation checks.
-}
recompile :: [CompatGHC.CommandLineOption] -> IO CompatGHC.PluginRecompile
recompile :: [CommandLineOption] -> IO PluginRecompile
recompile =
  ((CommandLineOption, Fingerprint) -> PluginRecompile)
-> IO (CommandLineOption, Fingerprint) -> IO PluginRecompile
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fingerprint -> PluginRecompile
CompatGHC.MaybeRecompile (Fingerprint -> PluginRecompile)
-> ((CommandLineOption, Fingerprint) -> Fingerprint)
-> (CommandLineOption, Fingerprint)
-> PluginRecompile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommandLineOption, Fingerprint) -> Fingerprint
forall a b. (a, b) -> b
snd) (IO (CommandLineOption, Fingerprint) -> IO PluginRecompile)
-> ([CommandLineOption] -> IO (CommandLineOption, Fingerprint))
-> [CommandLineOption]
-> IO PluginRecompile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> IO (CommandLineOption, Fingerprint)
getConfigPathAndFingerprint

-- | Load the config into the global state, if it isn't there.
loadConfigIfNeeded :: [CompatGHC.CommandLineOption] -> IO Config.Config
loadConfigIfNeeded :: [CommandLineOption] -> IO Config
loadConfigIfNeeded [CommandLineOption]
commandLineOpts = do
  mbConfigWithFingerprint <- MVar (Config, Fingerprint) -> IO (Maybe (Config, Fingerprint))
forall a. MVar a -> IO (Maybe a)
MVar.tryReadMVar MVar (Config, Fingerprint)
globalConfigState
  case mbConfigWithFingerprint of
    Just (Config
conf, Fingerprint
mvarFingerprint) -> do
      (configPath, currentFingerprint) <- [CommandLineOption] -> IO (CommandLineOption, Fingerprint)
getConfigPathAndFingerprint [CommandLineOption]
commandLineOpts
      -- A small optimization here, if the fingerprint is unchanged we do not need to reload the
      -- config. If it has changed then make sure to reload the config.
      if currentFingerprint == mvarFingerprint
        then pure conf
        else do
          loadedConfig <- Config.loadConfig configPath
          _ <- MVar.tryPutMVar globalConfigState (loadedConfig, currentFingerprint)
          pure loadedConfig
    Maybe (Config, Fingerprint)
Nothing -> do
      (configPath, currentFingerprint) <- [CommandLineOption] -> IO (CommandLineOption, Fingerprint)
getConfigPathAndFingerprint [CommandLineOption]
commandLineOpts
      loadedConfig <- Config.loadConfig configPath
      -- If we've been beaten to filling the global config, then oh well, but we do not want to
      -- block on it.
      _ <- MVar.tryPutMVar globalConfigState (loadedConfig, currentFingerprint)
      pure loadedConfig

{- | Parse the command line options for the path to the config and compute the fingerprint of that
config.
-}
getConfigPathAndFingerprint :: [CompatGHC.CommandLineOption] -> IO (FilePath, CompatGHC.Fingerprint)
getConfigPathAndFingerprint :: [CommandLineOption] -> IO (CommandLineOption, Fingerprint)
getConfigPathAndFingerprint [CommandLineOption]
commandLineOpts = do
  configPath <- (Options -> CommandLineOption)
-> IO Options -> IO CommandLineOption
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Options -> CommandLineOption
Options.configPath (IO Options -> IO CommandLineOption)
-> IO Options -> IO CommandLineOption
forall a b. (a -> b) -> a -> b
$ [CommandLineOption] -> IO Options
Options.parseGivenOptions [CommandLineOption]
commandLineOpts
  fingerprint <- CompatGHC.getFileHash configPath
  pure (configPath, fingerprint)