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 Control.Exception as E
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 = flip E.catches handlers $ do

  debugM _LOG_NAME "run external command."

  (fromHaskellHandle, toExternalHandle) <- createPipe
  (fromExternalHandle, toHaskellHandle) <- createPipe

  osEnc <- getReadHandleEncoding

  hSetBuffering toHaskellHandle NoBuffering
  hSetEncoding toHaskellHandle  osEnc

  hSetBuffering fromHaskellHandle NoBuffering
  hSetEncoding fromHaskellHandle  utf8

  hSetBuffering toExternalHandle NoBuffering
  hSetEncoding toExternalHandle utf8

  hSetBuffering fromExternalHandle NoBuffering
  hSetEncoding fromExternalHandle  osEnc


  debugM _LOG_NAME $ "external command : " ++ cmd ++ " " ++ (L.intercalate " " opts)
  ghciProc <- runProcess cmd opts curDir Nothing (Just fromHaskellHandle) (Just toHaskellHandle) (Just toHaskellHandle)

  return $ ExternalCommandData (Just toExternalHandle) (Just fromExternalHandle) (Just fromExternalHandle) (Just ghciProc)

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      criticalM _LOG_NAME ("run:" ++ show e)
      return $ ExternalCommandData Nothing Nothing Nothing Nothing

-- |
--
--
waitExit :: ExternalCommandData -> IO ExitCode
waitExit (ExternalCommandData _ _ _ (Just ghciProc)) = flip E.catches handlers $ do
  waitForProcess ghciProc
  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      criticalM _LOG_NAME ("waitExit:" ++ show e)
      return $ ExitFailure 2
waitExit _ = do
  criticalM _LOG_NAME "waitExit"
  return $ ExitFailure 2


-- |
--
--
writeLine :: ExternalCommandData -> String -> IO ()
writeLine (ExternalCommandData (Just ghciIn) _ _ _) cmd = flip E.catches handlers $ hIsOpen ghciIn >>= \case
  False -> criticalM _LOG_NAME "[writeLine] handle not open."
  True  -> debugM _LOG_NAME ("[writeLine]" ++ cmd) >> hPutStrLn ghciIn cmd
  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("writeLine:" ++ show e)

writeLine _ _ = criticalM _LOG_NAME "[writeLine] handle is nothing."


-- |
--
--
readWhile :: ExternalCommandData -> (String -> Bool) -> IO String
readWhile (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ 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'

    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readWhile:" ++ show e) >> return ""

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


-- |
--
--
readLineWhileIO :: ExternalCommandData -> ([String] -> IO Bool) -> IO [String]
readLineWhileIO (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ 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'

    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readLineWhileIO:" ++ show e) >> return []

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