{-# LANGUAGE CPP #-}

module GhcDump.Plugin where

import Data.Maybe
import qualified Data.ByteString.Lazy as BSL
import qualified Codec.Serialise as Ser
import GhcPlugins hiding (TB)
#if !MIN_VERSION_ghc(8,8,0)
import CoreMonad (pprPassDetails)
#endif
import ErrUtils (showPass)
import Text.Printf
import System.FilePath
import System.Directory

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)

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
showSDocDump DynFlags
dflags (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
todo SDoc -> SDoc -> SDoc
GhcPlugins.<> 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" (IO ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> CoreM ModGuts)
-> (ModGuts -> IO ModGuts) -> CorePluginPass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Int -> CommandLineOption -> ModGuts -> IO ModGuts
dumpIn DynFlags
dflags Int
n CommandLineOption
phase)

dumpIn :: DynFlags -> Int -> String -> ModGuts -> IO ModGuts
dumpIn :: DynFlags -> Int -> CommandLineOption -> ModGuts -> IO ModGuts
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
    DynFlags -> CommandLineOption -> IO ()
showPass DynFlags
dflags (CommandLineOption -> IO ()) -> CommandLineOption -> IO ()
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)
    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
    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 (CommandLineOption -> ModGuts -> SModule
cvtModule CommandLineOption
phase ModGuts
guts)
    ModGuts -> IO ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts