{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}

-- | A ghc plugin that creates `.ghc.flags` files populated with the flags that
--   were last used to invoke ghc for some modules, for consumption by tools
--   that need to know the build parameters.
--
--   https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#compiler-plugins
module GhcFlags.Plugin
  ( plugin,
  )
where

import Control.Exception (finally, onException)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Foldable (traverse_)
import Data.IORef
import Data.List (stripPrefix)
import Data.Time.Clock (diffTimeToPicoseconds, getCurrentTime, utctDayTime)
import qualified GHC
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import qualified GHC.Plugins as GHC
import qualified GHC.Driver.Backend as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Plugins as GHC
#else
import qualified GhcPlugins as GHC
#endif
import System.Directory (doesFileExist, removeFile, renameFile)
import System.Environment
import System.IO.Error (catchIOError)
import System.IO.Unsafe (unsafePerformIO)

plugin :: GHC.Plugin
plugin :: Plugin
plugin =
  Plugin
GHC.defaultPlugin
    { installCoreToDos :: CorePlugin
GHC.installCoreToDos = CorePlugin
install
#if MIN_VERSION_GLASGOW_HASKELL(8, 6, 0, 0)
    , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
GHC.pluginRecompile = [CommandLineOption] -> IO PluginRecompile
GHC.purePlugin
#endif
    }

-- Only run "write" once per process, unfortunately there is no other way to
-- inject an IORef except to use Unsafe.
lock :: IORef Bool
lock :: IORef Bool
lock = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Bool
False

install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo]
install :: CorePlugin
install [CommandLineOption]
_ [CoreToDo]
core = do
  Bool
written <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
lock (Bool
True,)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
written forall (m :: * -> *). (MonadIO m, HasDynFlags m) => m ()
write
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [CoreToDo]
core

-- This only supports ghc being called with directories and home modules. That
-- means we don't support incremental compilation where ghc is called with
-- explicit filenames and dependencies. There are cases where the .ghc.flags may
-- get out of date, e.g. adding / removing home modules. The simple solution is
-- that tools using .ghc.flags should recalculate the home modules if they want
-- to support incremental compilation.
write :: (MonadIO m, GHC.HasDynFlags m) => m ()
write :: forall (m :: * -> *). (MonadIO m, HasDynFlags m) => m ()
write = do
  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  [CommandLineOption]
args <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO [CommandLineOption]
getArgs
  Maybe CommandLineOption
ghcPath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CommandLineOption -> IO (Maybe CommandLineOption)
lookupEnv CommandLineOption
"PATH"

  -- downstream tools shouldn't use this plugin, or all hell will break loose
  let ghcFlags :: CommandLineOption
ghcFlags = [CommandLineOption] -> CommandLineOption
unwords forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [CommandLineOption
"-fplugin", CommandLineOption
"GhcFlags.Plugin"] [] [CommandLineOption]
args
      paths :: [CommandLineOption]
paths = DynFlags -> [CommandLineOption]
GHC.importPaths DynFlags
dflags
      writeGhcFlags :: CommandLineOption -> IO ()
writeGhcFlags CommandLineOption
path = CommandLineOption -> CommandLineOption -> IO ()
writeDifferent (CommandLineOption
path forall a. Semigroup a => a -> a -> a
<> CommandLineOption
"/.ghc.flags") CommandLineOption
ghcFlags
      writeGhcPath :: CommandLineOption -> IO ()
writeGhcPath CommandLineOption
path = case Maybe CommandLineOption
ghcPath of
        Just CommandLineOption
p -> CommandLineOption -> CommandLineOption -> IO ()
writeDifferent (CommandLineOption
path forall a. Semigroup a => a -> a -> a
<> CommandLineOption
"/.ghc.path") CommandLineOption
p
        Maybe CommandLineOption
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)
      enable = GHC.backendWritesFiles $ GHC.backend dflags
#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
      enable :: Bool
enable = Backend -> Bool
GHC.backendProducesObject forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
GHC.backend DynFlags
dflags
#else
      enable = case GHC.hscTarget dflags of
        GHC.HscInterpreted -> False
        GHC.HscNothing -> False
        _ -> True
#endif

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enable forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ CommandLineOption -> IO ()
writeGhcFlags [CommandLineOption]
paths
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ CommandLineOption -> IO ()
writeGhcPath [CommandLineOption]
paths

-- Only writes out the file when it will result in changes, and silently fails
-- on exceptions because the plugin should never interrupt normal ghc work. The
-- write is done atomically (via a temp file) otherwise it is prone to a lot of
-- crosstalk and then all writers fail to update the file.
writeDifferent :: FilePath -> String -> IO ()
writeDifferent :: CommandLineOption -> CommandLineOption -> IO ()
writeDifferent CommandLineOption
file CommandLineOption
content =
  IO () -> IO ()
ignoreIOExceptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
isDifferent forall a b. (a -> b) -> a -> b
$ do
    UTCTime
time <- IO UTCTime
getCurrentTime
    let hash :: Integer
hash = DiffTime -> Integer
diffTimeToPicoseconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> DiffTime
utctDayTime forall a b. (a -> b) -> a -> b
$ UTCTime
time
        tmp :: CommandLineOption
tmp = CommandLineOption
file forall a. Semigroup a => a -> a -> a
<> CommandLineOption
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> CommandLineOption
show Integer
hash
    forall a b. IO a -> IO b -> IO a
finally
      (CommandLineOption -> CommandLineOption -> IO ()
writeFile CommandLineOption
tmp CommandLineOption
content forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CommandLineOption -> CommandLineOption -> IO ()
renameFile CommandLineOption
tmp CommandLineOption
file)
      (CommandLineOption -> IO ()
removeFile CommandLineOption
tmp)
  where
    isDifferent :: IO Bool
isDifferent =
      forall a b. IO a -> IO b -> IO a
onException
        (forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (CommandLineOption -> IO Bool
doesFileExist CommandLineOption
file) ((CommandLineOption
content forall a. Eq a => a -> a -> Bool
/=) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandLineOption -> IO CommandLineOption
readFile CommandLineOption
file) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True))
        (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)

-- from Data.List.Extra
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace :: forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [] [a]
_ [a]
_ = forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"Extra.replace, first argument cannot be empty"
replace [a]
from [a]
to [a]
xs | Just [a]
xs' <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
from [a]
xs = [a]
to forall a. [a] -> [a] -> [a]
++ forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
from [a]
to [a]
xs'
replace [a]
from [a]
to (a
x : [a]
xs) = a
x forall a. a -> [a] -> [a]
: forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
from [a]
to [a]
xs
replace [a]
_ [a]
_ [] = []

-- from Control.Monad.Extra
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
b m ()
t = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m ()
t (forall (m :: * -> *) a. Monad m => a -> m a
return ())

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m a
t m a
f = do Bool
b' <- m Bool
b; if Bool
b' then m a
t else m a
f

-- from System.Directory.Internal
ignoreIOExceptions :: IO () -> IO ()
ignoreIOExceptions :: IO () -> IO ()
ignoreIOExceptions IO ()
io = IO ()
io forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())