{-# LANGUAGE CPP #-}

module GhcDump.Plugin where

#if MIN_VERSION_ghc(9,2,0)
import GHC (getLogger)
#endif

#if MIN_VERSION_ghc(9,0,0)
import GHC.Utils.Error (showPass)
import GHC.Plugins hiding (TB)
import qualified GHC.Utils.Outputable as Outputable ((<>))

#else

#if !MIN_VERSION_ghc(8,8,0)
import CoreMonad (pprPassDetails)
#endif
import GhcPlugins hiding (TB)
import qualified GhcPlugins as Outputable ((<>))
import ErrUtils (showPass)
#endif

import Data.Maybe
import Text.Printf

import System.FilePath
import System.Directory
import qualified Data.ByteString.Lazy as BSL
import qualified Codec.Serialise as Ser

import GhcDump.Convert

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin { installCoreToDos :: CorePlugin
installCoreToDos = CorePlugin
install }

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install [CommandLineOption]
_opts [CoreToDo]
todo = do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    [CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> [CoreToDo] -> [CoreToDo]
intersperseDumps DynFlags
dflags [CoreToDo]
todo)

showDump :: DynFlags -> SDoc -> String
#if MIN_VERSION_ghc(9,2,0)
showDump _dflags = showSDocDump defaultSDocContext
#else
showDump :: DynFlags -> SDoc -> CommandLineOption
showDump DynFlags
dflags = DynFlags -> SDoc -> CommandLineOption
showSDocDump DynFlags
dflags
#endif

intersperseDumps :: DynFlags -> [CoreToDo] -> [CoreToDo]
intersperseDumps :: DynFlags -> [CoreToDo] -> [CoreToDo]
intersperseDumps DynFlags
dflags = Int -> CommandLineOption -> [CoreToDo] -> [CoreToDo]
go Int
0 CommandLineOption
"desugar"
  where
    go :: Int -> CommandLineOption -> [CoreToDo] -> [CoreToDo]
go Int
n CommandLineOption
phase (CoreToDo
todo : [CoreToDo]
rest) = Int -> CommandLineOption -> CoreToDo
pass Int
n CommandLineOption
phase CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> CommandLineOption -> [CoreToDo] -> [CoreToDo]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CommandLineOption
phase' [CoreToDo]
rest
      where phase' :: CommandLineOption
phase' = DynFlags -> SDoc -> CommandLineOption
showDump DynFlags
dflags (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
todo SDoc -> SDoc -> SDoc
Outputable.<> CommandLineOption -> SDoc
text CommandLineOption
":" SDoc -> SDoc -> SDoc
<+> CoreToDo -> SDoc
pprPassDetails CoreToDo
todo)
    go Int
n CommandLineOption
phase [] = [Int -> CommandLineOption -> CoreToDo
pass Int
n CommandLineOption
phase]

    pass :: Int -> CommandLineOption -> CoreToDo
pass Int
n CommandLineOption
phase = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
"DumpCore" (DynFlags -> Int -> CommandLineOption -> CorePluginPass
dumpIn DynFlags
dflags Int
n CommandLineOption
phase)

-- Compatibility shim
showPass' :: String -> CoreM ()
showPass' :: CommandLineOption -> CoreM ()
showPass' CommandLineOption
s = do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if MIN_VERSION_ghc(9,2,0)
    logger <- getLogger
    liftIO $ showPass logger dflags s
#else
    IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> CommandLineOption -> IO ()
showPass DynFlags
dflags CommandLineOption
s
#endif

dumpIn :: DynFlags -> Int -> String -> ModGuts -> CoreM ModGuts
dumpIn :: DynFlags -> Int -> CommandLineOption -> CorePluginPass
dumpIn DynFlags
dflags Int
n CommandLineOption
phase ModGuts
guts = do
    let prefix :: CommandLineOption
prefix = CommandLineOption -> Maybe CommandLineOption -> CommandLineOption
forall a. a -> Maybe a -> a
fromMaybe CommandLineOption
"dump" (Maybe CommandLineOption -> CommandLineOption)
-> Maybe CommandLineOption -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe CommandLineOption
dumpPrefix DynFlags
dflags
        fname :: CommandLineOption
fname = CommandLineOption -> CommandLineOption -> Int -> CommandLineOption
forall r. PrintfType r => CommandLineOption -> r
printf CommandLineOption
"%spass-%04u.cbor" CommandLineOption
prefix Int
n
    CommandLineOption -> CoreM ()
showPass' (CommandLineOption -> CoreM ()) -> CommandLineOption -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"GhcDump: Dumping core to "CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++CommandLineOption
fname
    let in_dump_dir :: CommandLineOption -> CommandLineOption
in_dump_dir = (CommandLineOption -> CommandLineOption)
-> (CommandLineOption -> CommandLineOption -> CommandLineOption)
-> Maybe CommandLineOption
-> CommandLineOption
-> CommandLineOption
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommandLineOption -> CommandLineOption
forall a. a -> a
id CommandLineOption -> CommandLineOption -> CommandLineOption
(</>) (DynFlags -> Maybe CommandLineOption
dumpDir DynFlags
dflags)
    IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Bool -> CommandLineOption -> IO ()
createDirectoryIfMissing Bool
True (CommandLineOption -> IO ()) -> CommandLineOption -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> CommandLineOption
takeDirectory (CommandLineOption -> CommandLineOption)
-> CommandLineOption -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> CommandLineOption
in_dump_dir CommandLineOption
fname
    IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> ByteString -> IO ()
BSL.writeFile (CommandLineOption -> CommandLineOption
in_dump_dir CommandLineOption
fname) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ SModule -> ByteString
forall a. Serialise a => a -> ByteString
Ser.serialise (DynFlags -> CommandLineOption -> ModGuts -> SModule
cvtModule DynFlags
dflags CommandLineOption
phase ModGuts
guts)
    CorePluginPass
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts