{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}


--------------------------------------------------------------------------------
-- |
--
-- Module      :  System.Process.Ghci
-- Description :  GHCi as a process
-- Copyright   :  (c) Alice Rixte 2024
-- License     :  BSD 3
-- Maintainer  :  alice.rixte@u-bordeaux.fr
-- Stability   :  unstable
-- Portability :  non-portable (GHC extensions)
--
-- Run GHCi as a process, and execute commands.
--
-- = Usage
--
-- >>> ghci <- startGhci Quiet "ghci" []
-- >>> execGhciCmd ghci Quiet "1+2"
-- GhciResult {ghciErr = "", ghciOut = "3"}
--
--------------------------------------------------------------------------------

module System.Process.Ghci
  ( Ghci (..)
  , startGhci
  , GhciResult (..)
  , execGhciCmd
  )
where

import Control.Exception
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import GHC.Generics
import System.IO
import System.IO.Error
import System.Process
import Data.String
import Data.Text

import System.Console.CmdArgs.Verbosity



import Data.Aeson

-- | A GHCi process
--
data Ghci = Ghci
  { Ghci -> Handle
ghciIn :: Handle -- ^ Standard input
  , Ghci -> TMVar String
ghciErrVar :: TMVar String -- ^ Current line on stderr
  , Ghci -> TMVar String
ghciOutVar :: TMVar String -- ^ Current line on stdout
  , Ghci -> ProcessHandle
ghciProcess :: ProcessHandle -- ^ Process handle
  , Ghci -> ThreadId
ghciErrId :: ThreadId -- ^ Stderr listener thread
  , Ghci -> ThreadId
ghciOutId :: ThreadId -- ^ Stdout listener thread
  }


-- | Start a GHCi process.
--
-- >>> ghci = startGhci Normal "ghci" []
--
-- >>> ghci = startGhci Loud "stack" ["ghci"]
--
startGhci ::
      Verbosity -- ^  When @verbosity >= 'Normal'@, the entire output
                --    of GHCi is printed
  -> String     -- ^ The command to run (e.g. "ghci", "cabal" or "stack")
  -> [String]   -- ^ The list of the command's arguments
                -- (e.g. "repl" for "cabal" or "ghci" for "stack")
  -> IO Ghci
startGhci :: Verbosity -> String -> [String] -> IO Ghci
startGhci Verbosity
v String
cmd [String]
args = do
  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
chans <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
cmd [String]
args) { std_in = CreatePipe
                                  , std_err = CreatePipe
                                  , std_out = CreatePipe
                                  }
  case (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
chans of
    (Just Handle
hin, Just Handle
hout , Just Handle
herr , ProcessHandle
hp) -> do
      TMVar String
verr <- IO (TMVar String)
forall a. IO (TMVar a)
newEmptyTMVarIO
      TMVar String
vout <- IO (TMVar String)
forall a. IO (TMVar a)
newEmptyTMVarIO

      ThreadId
errId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TMVar String -> Handle -> IO ()
listenHandle TMVar String
verr Handle
herr
      ThreadId
outId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TMVar String -> Handle -> IO ()
listenHandle TMVar String
vout Handle
hout

      let g :: Ghci
g = Handle
-> TMVar String
-> TMVar String
-> ProcessHandle
-> ThreadId
-> ThreadId
-> Ghci
Ghci Handle
hin TMVar String
verr TMVar String
vout ProcessHandle
hp ThreadId
errId ThreadId
outId

      -- the following is very hacky : Sometimes, "stack ghci" may ask some file
      -- to the user. For this reason we send ghci a confirmation for whatever
      -- default values it proposes, then wait for 200 ms to make sur ghci did
      -- receive that answer.
      Handle -> String -> IO ()
flushGhciCmd (Ghci -> Handle
ghciIn Ghci
g) String
"\n"
      Int -> IO ()
threadDelay Int
2000000 -- wait 200 ms to make sure GHCi is ready to listen

      GhciResult
_ <- Ghci -> Verbosity -> IO GhciResult
waitGhciResult Ghci
g Verbosity
v

      Ghci -> IO Ghci
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ghci
g
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ -> String -> IO Ghci
forall a. HasCallStack => String -> a
error String
"Error : Ghci command failed."

-- | Listen to a handle by putting lines into a mutable variable.
--
listenHandle :: TMVar String -> Handle -> IO ()
listenHandle :: TMVar String -> Handle -> IO ()
listenHandle TMVar String
v Handle
h =
  IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
s <- Handle -> IO String
hGetLine Handle
h
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar String -> String -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar String
v String
s) IOError -> IO ()
handler
  where
    handler :: IOError -> IO ()
    handler :: IOError -> IO ()
handler IOError
err =
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOError -> Bool
isEOFError IOError
err) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall a e. Exception e => e -> a
throw IOError
err

-- | Merge stderr and stdout streams.
--
mergeErrOut :: TMVar String -> TMVar String -> IO (Either String String)
mergeErrOut :: TMVar String -> TMVar String -> IO (Either String String)
mergeErrOut TMVar String
verr TMVar String
vout=
  STM (Either String String) -> IO (Either String String)
forall a. STM a -> IO a
atomically (STM (Either String String) -> IO (Either String String))
-> STM (Either String String) -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ (String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String)
-> STM String -> STM (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar String -> STM String
forall a. TMVar a -> STM a
takeTMVar TMVar String
verr) STM (Either String String)
-> STM (Either String String) -> STM (Either String String)
forall a. STM a -> STM a -> STM a
`orElse`
      ( String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> (String -> String) -> String -> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cleanResultString (String -> Either String String)
-> STM String -> STM (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar String -> STM String
forall a. TMVar a -> STM a
takeTMVar TMVar String
vout)



-- | The result printed by GHCi.
--
data GhciResult = GhciResult
  { GhciResult -> Text
ghciErr :: Text -- Errors and warnings of GHCi
  , GhciResult -> Text
ghciOut :: Text -- Output of GHCi
  }
  deriving (Int -> GhciResult -> String -> String
[GhciResult] -> String -> String
GhciResult -> String
(Int -> GhciResult -> String -> String)
-> (GhciResult -> String)
-> ([GhciResult] -> String -> String)
-> Show GhciResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GhciResult -> String -> String
showsPrec :: Int -> GhciResult -> String -> String
$cshow :: GhciResult -> String
show :: GhciResult -> String
$cshowList :: [GhciResult] -> String -> String
showList :: [GhciResult] -> String -> String
Show, (forall x. GhciResult -> Rep GhciResult x)
-> (forall x. Rep GhciResult x -> GhciResult) -> Generic GhciResult
forall x. Rep GhciResult x -> GhciResult
forall x. GhciResult -> Rep GhciResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GhciResult -> Rep GhciResult x
from :: forall x. GhciResult -> Rep GhciResult x
$cto :: forall x. Rep GhciResult x -> GhciResult
to :: forall x. Rep GhciResult x -> GhciResult
Generic)
  deriving NonEmpty GhciResult -> GhciResult
GhciResult -> GhciResult -> GhciResult
(GhciResult -> GhciResult -> GhciResult)
-> (NonEmpty GhciResult -> GhciResult)
-> (forall b. Integral b => b -> GhciResult -> GhciResult)
-> Semigroup GhciResult
forall b. Integral b => b -> GhciResult -> GhciResult
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: GhciResult -> GhciResult -> GhciResult
<> :: GhciResult -> GhciResult -> GhciResult
$csconcat :: NonEmpty GhciResult -> GhciResult
sconcat :: NonEmpty GhciResult -> GhciResult
$cstimes :: forall b. Integral b => b -> GhciResult -> GhciResult
stimes :: forall b. Integral b => b -> GhciResult -> GhciResult
Semigroup via Generically GhciResult
  deriving Semigroup GhciResult
GhciResult
Semigroup GhciResult =>
GhciResult
-> (GhciResult -> GhciResult -> GhciResult)
-> ([GhciResult] -> GhciResult)
-> Monoid GhciResult
[GhciResult] -> GhciResult
GhciResult -> GhciResult -> GhciResult
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: GhciResult
mempty :: GhciResult
$cmappend :: GhciResult -> GhciResult -> GhciResult
mappend :: GhciResult -> GhciResult -> GhciResult
$cmconcat :: [GhciResult] -> GhciResult
mconcat :: [GhciResult] -> GhciResult
Monoid via Generically GhciResult

instance ToJSON GhciResult where
  toEncoding :: GhciResult -> Encoding
toEncoding = Options -> GhciResult -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

instance FromJSON GhciResult

-- | Sends a command to ghci and wait for its result.
--
-- >>> execGhciCmd ghci Normal "1+2"
-- GhciResult {ghciErr = "", ghciOut = "3"}
--
execGhciCmd
  :: Ghci       -- ^ A GHCi process
  -> Verbosity  -- ^ When @verbosity >= Normal@,  the entire output
                --    of GHCi is printed
  -> String     -- ^ The command to execute
  -> IO GhciResult -- ^ The result of the execution
execGhciCmd :: Ghci -> Verbosity -> String -> IO GhciResult
execGhciCmd Ghci
g Verbosity
v String
cmd = do
  Handle -> String -> IO ()
flushGhciCmd (Ghci -> Handle
ghciIn Ghci
g) String
cmd
  Ghci -> Verbosity -> IO GhciResult
waitGhciResult Ghci
g Verbosity
v



-- | Wait for GHCi to complete its computation
--
waitGhciResult :: Ghci -> Verbosity ->  IO GhciResult
waitGhciResult :: Ghci -> Verbosity -> IO GhciResult
waitGhciResult Ghci
g Verbosity
v  = do

  -- this is a hack : we send a "putStrLn" command to ghci in order to be able
  -- to wait for the result of the command.
  Handle -> String -> IO ()
flushGhciCmd (Ghci -> Handle
ghciIn Ghci
g) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"putStrLn\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
readyString String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\n"
  GhciResult -> IO GhciResult
loop GhciResult
forall a. Monoid a => a
mempty

  where
    loop :: GhciResult -> IO GhciResult
loop GhciResult
acc = do
      Either String String
s <- TMVar String -> TMVar String -> IO (Either String String)
mergeErrOut (Ghci -> TMVar String
ghciErrVar Ghci
g) (Ghci -> TMVar String
ghciOutVar Ghci
g)
      if Either String String
s Either String String -> Either String String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Either String String
forall a b. b -> Either a b
Right String
readyString then
        GhciResult -> IO GhciResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GhciResult
acc
      else do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          case Either String String
s of
            Left String
s' -> do
              Handle -> String -> IO ()
hPutStr Handle
stderr String
s'
              Handle -> Char -> IO ()
hPutChar Handle
stderr Char
'\n'
              Handle -> IO ()
hFlush Handle
stderr
            Right String
s' -> do
              String -> IO ()
putStrLn String
s'
              Handle -> IO ()
hFlush Handle
stdout
        GhciResult -> IO GhciResult
loop (GhciResult -> Either String String -> GhciResult
appendGhciResult GhciResult
acc Either String String
s)

-- | A very unlikely string that we make ghci print in order to know when ghci
-- is finished.
--
-- This is a hack but it works well. The same hack is used by lhs2tex.
--
readyString :: String
readyString :: String
readyString = String
"`}$/*^`a`('))}{h}"

-- | Flush a string to the standard input of of ghci.
--
-- Multiple line strings are
-- accepted and will be surrounded by ":{" and ":}"
--
flushGhciCmd :: Handle -> String -> IO ()
flushGhciCmd :: Handle -> String -> IO ()
flushGhciCmd Handle
hin String
cmd = do
  Handle -> String -> IO ()
hPutStr Handle
hin (String
":{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n:}\n") -- TODO optimization when no newline ?
  Handle -> IO ()
hFlush Handle
hin

-- | Remove the @"ghci> "@ and @"ghci| "@ prefixes from the output stream of
-- ghci.
--
cleanResultString :: String -> String
cleanResultString :: String -> String
cleanResultString (Char
'g' : Char
'h' : Char
'c' : Char
'i' : Char
'>': Char
' ' : String
s) =
  String -> String
cleanResultString String
s
cleanResultString (Char
'g' : Char
'h' : Char
'c' : Char
'i' : Char
'|': Char
' ' : String
s) =
  String -> String
cleanResultString String
s
cleanResultString String
s = String
s


-- | Utility function that merges the stderr and the stdout streams of
-- ghci.
--
appendGhciResult :: GhciResult -> Either String String -> GhciResult
appendGhciResult :: GhciResult -> Either String String -> GhciResult
appendGhciResult GhciResult
acc (Left String
s) =
  GhciResult
acc { ghciErr = ghciErr acc <> fromString s }
appendGhciResult GhciResult
acc (Right String
s) =
  GhciResult
acc { ghciOut = ghciOut acc <> fromString s }