-----------------------------------------------------------------------------
-- |
-- Module      :  GhcStdin
-- Copyright   :  (c) Alexey Radkov 2022
-- License     :  BSD-style
--
-- Maintainer  :  alexey.radkov@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (requires GHC with support of plugins)
--
-- A frontend plugin for GHC to compile source code from the standard input.
--
-----------------------------------------------------------------------------


module GhcStdin (frontendPlugin) where

import           GHC.Paths
#if MIN_VERSION_ghc(9,0,2)
import           GHC.Plugins
#else
import           GhcPlugins
#endif
import           Control.Monad
import qualified Data.ByteString as B
import           System.IO
import           System.IO.Temp
import           System.Process
import           System.Exit

-- | Frontend plugin for GHC to compile source code from the standard input.
--
-- In GHC, it is not possible to read source code from the standard input.
--
-- @
-- __$__ echo \'module Main where main = putStrLn \"Ok\"\' | ghc -o simple_ok
-- ghc-9.2.3: no input files
-- Usage: For basic information, try the \`--help\' option.
-- @
--
-- This plugin makes this possible.
--
-- @
-- __$__ echo \'module Main where main = putStrLn \"Ok\"\' | ghc __/--frontend GhcStdin/__ /-ffrontend-opt=\"-o simple_ok\"/
-- [1 of 1] Compiling Main             ( ghc-stdin-d8c31cf0ed893d79\/ghc-stdin260612-0.hs, ghc-stdin-d8c31cf0ed893d79\/ghc-stdin260612-0.o )
-- Linking simple_ok ...
-- __$__ ./simple_ok
-- Ok
-- @
--
-- Notice that GHC flags are passed via /-ffrontend-opt/ in a single string.
--
-- Another use case is collecting exported FFI C functions from a module and
-- putting them in a new shared library.
--
-- @
-- __$__ export NGX_MODULE_PATH=\/var\/lib\/nginx\/x86_64-linux-ghc-9.2.3
-- __$__ echo \'module NgxHealthcheck where import NgxExport.Healthcheck ()\' | ghc __/--frontend GhcStdin/__ /-ffrontend-opt=\"-Wall -O2 -dynamic -shared -fPIC -lHSrts_thr-ghc$(ghc --numeric-version) -L$NGX_MODULE_PATH -lngx_healthcheck_plugin -o ngx_healthcheck.so\"/ 
-- [1 of 1] Compiling NgxHealthcheck   ( ghc-stdin-74de48274545714b\/ghc-stdin266454-0.hs, ghc-stdin-74de48274545714b\/ghc-stdin266454-0.o )
-- Linking ngx_healthcheck.so ...
-- @
--
-- (this is a real-world example taken from
-- [nginx-healthcheck-plugin](https://github.com/lyokha/nginx-healthcheck-plugin)).
--
-- Internally, the plugin creates a temporary directory with a temporary source
-- file inside it with the contents read from the standard input. Then it spawns
-- another GHC process to compile this file with the options passed in
-- /-ffrontend-opt/. Note that the options get collected by 'words' without
-- passing them to a shell preprocessor which means that it is not possible to
-- escape spaces in their values with quotes or backslashes.
frontendPlugin :: FrontendPlugin
frontendPlugin :: FrontendPlugin
frontendPlugin = FrontendPlugin
defaultFrontendPlugin { frontend :: FrontendPluginAction
frontend = FrontendPluginAction
compileCodeFromStdin }

compileCodeFromStdin :: FrontendPluginAction
compileCodeFromStdin :: FrontendPluginAction
compileCodeFromStdin [String]
flags [(String, Maybe Phase)]
_ = IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$
    String -> String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
"." String
"ghc-stdin" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir ->
        String -> String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile String
dir String
"ghc-stdin.hs" ((String -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
src Handle
hsrc -> do
            ByteString
contents <- IO ByteString
B.getContents
            Handle -> ByteString -> IO ()
B.hPutStr Handle
hsrc ByteString
contents IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
hsrc
            -- FIXME: wordsOfHead won't hide spaces inside quotes correctly,
            -- but using spaces does not seem to be an often case in GHC options
            (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CreateProcess
proc String
ghc ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ String
src String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
wordsOfHead [String]
flags
            ExitCode
r <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
r ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
r
    where wordsOfHead :: [String] -> [String]
wordsOfHead [] = []
          wordsOfHead (String
x : [String]
_) = String -> [String]
words String
x