{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}
-- | Scaffolding for running, tracing, and dumping pipeline passes, used by
--   the compiler (ReWire.ModCache, ReWire.FrontEnd) and, for 'printHeader'
--   alone, by the embedder (ReWire.HSE.PassInfo).
module ReWire.Pass
      ( pass
      , printHeader
      , verb'
      ) where

import ReWire.Annotation (unAnn)
import ReWire.Config (Config, dump, outFile, verbose, pDebug)
import ReWire.Pretty (showt)

import Control.Lens ((^.))
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Data (Data)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import Numeric.Natural (Natural)
import System.FilePath ((-<.>), (<.>))
import Text.Pretty.Simple (pShowOpt, defaultOutputOptionsNoColor)

import qualified Data.Text      as T
import qualified Data.Text.IO   as T
import qualified Data.Text.Lazy as TL

-- | Run one numbered, named pipeline pass: announce it (verbose only, as
--   "[n] name"), run the transformation, then write the rendering of its
--   output to a file beside the output file when -d n (or --dump-all) is on
--   -- so "-d n" reads "dump the IR after pass n". The dump file is the
--   output file (or the given source file) with its extension replaced by
--   "\<n\>.\<ext\>" (e.g., MiniISA.6.eir); ext names the IR's textual format,
--   which the render argument produces. Under -v, the dump also carries the
--   IR's show output (indented by pretty-simple) in a comment, so it stays
--   parseable. Numbers are assigned consecutively at the call sites
--   (ReWire.ModCache and ReWire.FrontEnd for the compiler).
pass :: forall m a b. (MonadIO m, Data b, Show b) => Config -> FilePath -> Natural -> Text -> String -> (b -> Text) -> (a -> m b) -> a -> m b
pass :: forall (m :: * -> *) a b.
(MonadIO m, Data b, Show b) =>
Config
-> FilePath
-> Natural
-> Text
-> FilePath
-> (b -> Text)
-> (a -> m b)
-> a
-> m b
pass Config
conf FilePath
fp Natural
n Text
name FilePath
ext b -> Text
render a -> m b
f a
a = do
      Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf Text
msg
      b <- a -> m b
f a
a
      when ((conf^.dump) n) $ do
            let fout = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
fp (Config
confConfig
-> Getting (Maybe FilePath) Config (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^.Getting (Maybe FilePath) Config (Maybe FilePath)
Lens' Config (Maybe FilePath)
outFile) FilePath -> FilePath -> FilePath
-<.> (Natural -> FilePath
forall a. Show a => a -> FilePath
show Natural
n FilePath -> FilePath -> FilePath
<.> FilePath
ext)
            pDebug conf $ "Dumping the IR after pass " <> showt n <> " to file: " <> pack fout
            liftIO $ T.writeFile fout $ dumpText b
      pure b
      where msg :: Text
            msg :: Text
msg = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text
forall a. TextShow a => a -> Text
showt Natural
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

            dumpText :: b -> Text
            dumpText :: b -> Text
dumpText b
b = Text
"-- # " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> b -> Text
render b
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Config
confConfig -> Getting Bool Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Config Bool
Lens' Config Bool
verbose then Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
comment (Text
"## Show:\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> b -> Text
indented b
b) else Text
forall a. Monoid a => a
mempty)

            indented :: b -> Text
            indented :: b -> Text
indented = LazyText -> Text
TL.toStrict (LazyText -> Text) -> (b -> LazyText) -> b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> b -> LazyText
forall a. Show a => OutputOptions -> a -> LazyText
pShowOpt OutputOptions
defaultOutputOptionsNoColor (b -> LazyText) -> (b -> b) -> b -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
forall d. Data d => d -> d
unAnn

            comment :: Text -> Text
            comment :: Text -> Text
comment = [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

printHeader :: MonadIO m => Text -> m ()
printHeader :: forall (m :: * -> *). MonadIO m => Text -> m ()
printHeader Text
hd = do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn   Text
"-- # ==================================================="
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"-- # " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hd
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn   Text
"-- # ===================================================\n"

-- | Print a debug message (verbose only), passing the program through.
verb' :: MonadIO m => Config -> Text -> a -> m a
verb' :: forall (m :: * -> *) a. MonadIO m => Config -> Text -> a -> m a
verb' Config
conf Text
s a
a = Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf Text
s m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a