GHCiControl.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable  #-}

module Phoityne.IO.CUI.GHCiControl where

-- モジュール
import Phoityne.Constant
import Phoityne.IO.Utility

-- システム
import System.Process
import System.IO
import System.Exit
import System.Log.Logger
import qualified Data.List as L

-- |
--
--
data ExternalCommandData = ExternalCommandData
  {
    inExternalCommandData   :: Maybe Handle
  , outExternalCommandData  :: Maybe Handle
  , errExternalCommandData  :: Maybe Handle
  , procExternalCommandData :: Maybe ProcessHandle
  }


-- |
--
--
defaultExternalCommandData :: ExternalCommandData
defaultExternalCommandData = ExternalCommandData Nothing Nothing Nothing Nothing


-- |
--
--
run :: String -> [String] -> Maybe FilePath -> IO ExternalCommandData
run cmd opts curDir = do

  (stdInReadHandle, stdInWriteHandle) <- createPipe
  (outReadHandle, outWriteHandle)     <- createPipe

  hSetBuffering stdInReadHandle  NoBuffering
  hSetBuffering stdInWriteHandle NoBuffering

  hSetBuffering outReadHandle    NoBuffering
  hSetBuffering outWriteHandle   NoBuffering

  osEnc <- getReadHandleEncoding

  hSetEncoding stdInReadHandle  osEnc
  hSetEncoding stdInWriteHandle utf8

  hSetEncoding outReadHandle    osEnc
  hSetEncoding outWriteHandle   utf8

  debugM _LOG_NAME $ cmd ++ (L.intercalate " " opts)
  ghciProc <- runProcess cmd opts curDir Nothing (Just stdInReadHandle) (Just outWriteHandle) (Just outWriteHandle)

  return $ ExternalCommandData (Just stdInWriteHandle) (Just outReadHandle) (Just outReadHandle) (Just ghciProc)


-- |
--
--
waitExit :: ExternalCommandData -> IO ExitCode
waitExit (ExternalCommandData _ _ _ (Just ghciProc)) = do
  waitForProcess ghciProc
waitExit _ = do
  criticalM _LOG_NAME "waitExit"
  return $ ExitFailure 2


-- |
--
--
writeLine :: ExternalCommandData -> String -> IO ()
writeLine (ExternalCommandData (Just ghciIn) _ _ _) cmd = hIsOpen ghciIn >>= \case
  False -> criticalM _LOG_NAME "[writeLine] handle not open."
  True  -> debugM _LOG_NAME ("[writeLine]" ++ cmd) >> hPutStrLn ghciIn cmd
writeLine _ _ = criticalM _LOG_NAME "[writeLine] handle is nothing."


-- |
--
--
readWhile :: ExternalCommandData -> (String -> Bool) -> IO String
readWhile (ExternalCommandData _ (Just ghciOut) _ _) proc = go []
  where
    go acc = hIsEOF ghciOut >>= \case
      True -> return acc
      False -> do
        c <- hGetChar ghciOut
        let acc' = acc ++ [c]
        if proc acc' then go acc'
          else return acc'

readWhile _ _ = criticalM _LOG_NAME "readWhile" >> return ""


-- |
--
--
readLineWhileIO :: ExternalCommandData -> ([String] -> IO Bool) -> IO [String]
readLineWhileIO (ExternalCommandData _ (Just ghciOut) _ _) proc = go []
  where
    go acc = hIsEOF ghciOut >>= \case
      True -> return acc
      False -> do
        l <- hGetLine ghciOut
        let acc' = acc ++ [l]
        proc acc' >>= \case
          True  -> go acc'
          False -> return acc'

readLineWhileIO _ _ = criticalM _LOG_NAME "readLineWhileIO" >> return []