-----------------------------------------------------------------------------
-- |
-- 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
import           Safe

-- | 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-$(ghc --numeric-version)
-- __$__ echo \'module NgxHealthcheck where import NgxExport.Healthcheck ()\' | ghc __/--frontend GhcStdin/__ /-ffrontend-opt=\"-Wall -O2 -dynamic -shared -fPIC -flink-rts -threaded -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/.
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 a. IO a -> Ghc a
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
hsrc
            (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 -> CreateProcess
shell (String -> CreateProcess) -> String -> CreateProcess
forall a b. (a -> b) -> a -> b
$ String -> String
q String
ghc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
spc (String -> String
q String
src) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
spc (String -> [String] -> String
forall a. a -> [a] -> a
headDef String
"" [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 q :: String -> String
q String
s = let q' :: Char
q' = Char
'\'' in Char
q' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
q'
          spc :: String -> String
spc = (Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
:)