{-# LANGUAGE CPP #-}

-- | A ghc plugin that creates `.ghc.flags` files (and `.ghc.version`) 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 qualified Config as GHC
import           Control.Monad (when)
import           Control.Monad.IO.Class (liftIO)
import           Data.Foldable (traverse_)
import           Data.List (stripPrefix)
import qualified GHC
import qualified GhcPlugins as GHC
import           System.Directory (doesFileExist)
import           System.Environment
import           System.IO.Error (catchIOError)

plugin :: GHC.Plugin
plugin =
  GHC.defaultPlugin
    { GHC.installCoreToDos = install
#if MIN_VERSION_GLASGOW_HASKELL(8, 6, 0, 0)
    , GHC.pluginRecompile = GHC.purePlugin
#endif
    }

install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo]
install _ core = do
  dflags <- GHC.getDynFlags
  args <- liftIO $ getArgs

  -- downstream tools shouldn't use this plugin, or all hell will break loose
  let ghcFlags = unwords $ replace ["-fplugin", "GhcFlags.Plugin"] [] args

      -- TODO this currently only supports ghc being called with directories and
      -- home modules, we should also support calling with explicit file names.
      paths = GHC.importPaths dflags
      writeGhcFlags path = writeDifferent (path <> "/.ghc.flags") ghcFlags
      enable = case GHC.hscTarget dflags of
        GHC.HscInterpreted -> False
        GHC.HscNothing -> False
        _ -> True

  when enable $ liftIO $ do
    traverse_ writeGhcFlags paths
    writeDifferent ".ghc.version" GHC.cProjectVersion

  pure core

-- 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.
writeDifferent :: FilePath -> String -> IO ()
writeDifferent file content =
  ignoreIOExceptions
    $ whenM isDifferent (writeFile file content)
  where
    isDifferent =
      ifM (doesFileExist file) ((content /=) <$> readFile file) (pure True)

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

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

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM b t f = do b' <- b; if b' then t else f

-- from System.Directory.Internal
ignoreIOExceptions :: IO () -> IO ()
ignoreIOExceptions io = io `catchIOError` (\_ -> pure ())