{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}

module Haskell.Debug.Adapter.GHCi where

import Control.Monad.IO.Class
import Control.Lens
import qualified Data.ByteString as B
import Control.Concurrent.MVar
import Control.Monad.State.Lazy
import Control.Monad.Except
import GHC.IO.Encoding
import Distribution.System
import qualified System.Process as S
import qualified System.IO as S
import qualified System.Environment as S
import qualified Data.Map as M
import qualified Data.List as L

import Haskell.Debug.Adapter.Type
import qualified Haskell.Debug.Adapter.Utility as U
import Haskell.Debug.Adapter.Constant

#if __GLASGOW_HASKELL__ >= 906
import Control.Monad
#endif
---------------------------------------------------------------------------------
-- |
--  run ghci.
--
startGHCi :: String
          -> [String]
          -> FilePath
          -> M.Map String String
          -> AppContext ()
startGHCi :: ErrMsg -> [ErrMsg] -> ErrMsg -> Map ErrMsg ErrMsg -> AppContext ()
startGHCi ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs =
  forall a. IO a -> AppContext a
U.liftIOE (ErrMsg
-> [ErrMsg]
-> ErrMsg
-> Map ErrMsg ErrMsg
-> IO (Either ErrMsg GHCiProc)
startGHCiIO ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
(MonadState AppStores m, MonadIO m) =>
GHCiProc -> m ()
updateGHCi

  where
    updateGHCi :: GHCiProc -> m ()
updateGHCi GHCiProc
proc = do
      MVar GHCiProc
mvar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar GHCiProc)
ghciProcAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
      --_ <- liftIO $ takeMVar mvar
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar GHCiProc
mvar GHCiProc
proc


-- |
--
startGHCiIO :: String
            -> [String]
            -> FilePath
            -> M.Map String String
            -> IO (Either ErrMsg GHCiProc)
startGHCiIO :: ErrMsg
-> [ErrMsg]
-> ErrMsg
-> Map ErrMsg ErrMsg
-> IO (Either ErrMsg GHCiProc)
startGHCiIO ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs = do

  (Handle
fromPhoityneHandle, Handle
toGHCiHandle) <- IO (Handle, Handle)
S.createPipe
  (Handle
fromGHCiHandle, Handle
toPhoityneHandle) <- IO (Handle, Handle)
S.createPipe

  TextEncoding
osEnc <- IO TextEncoding
getReadHandleEncoding

  let bufMode :: BufferMode
bufMode = BufferMode
S.NoBuffering
  --let bufMode = S.BlockBuffering $ Just 1024

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
toPhoityneHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
toPhoityneHandle TextEncoding
osEnc
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
toPhoityneHandle forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.CRLF Newline
S.LF
  --S.hSetBinaryMode toPhoityneHandle True

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
fromPhoityneHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
fromPhoityneHandle  TextEncoding
S.utf8
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
fromPhoityneHandle forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.LF Newline
S.LF
  --S.hSetBinaryMode fromPhoityneHandle True

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
toGHCiHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
toGHCiHandle TextEncoding
S.utf8
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
toGHCiHandle forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.LF Newline
S.LF
  --S.hSetBinaryMode toGHCiHandle True

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
fromGHCiHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
fromGHCiHandle TextEncoding
osEnc
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
fromGHCiHandle forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.CRLF Newline
S.LF
  --S.hSetBinaryMode fromGHCiHandle True

  Maybe [(ErrMsg, ErrMsg)]
runEnvs <- IO (Maybe [(ErrMsg, ErrMsg)])
getRunEnv

  ProcessHandle
ghciGHCi <- ErrMsg
-> [ErrMsg]
-> Maybe ErrMsg
-> Maybe [(ErrMsg, ErrMsg)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
S.runProcess ErrMsg
cmd [ErrMsg]
opts (forall a. a -> Maybe a
Just ErrMsg
cwd) Maybe [(ErrMsg, ErrMsg)]
runEnvs (forall a. a -> Maybe a
Just Handle
fromPhoityneHandle) (forall a. a -> Maybe a
Just Handle
toPhoityneHandle) (forall a. a -> Maybe a
Just Handle
toPhoityneHandle)

  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Handle -> ProcessHandle -> GHCiProc
GHCiProc Handle
toGHCiHandle Handle
fromGHCiHandle Handle
fromGHCiHandle ProcessHandle
ghciGHCi

  where
    -- |
    --
    getReadHandleEncoding :: IO TextEncoding
    getReadHandleEncoding :: IO TextEncoding
getReadHandleEncoding = if
      | OS
Windows forall a. Eq a => a -> a -> Bool
== OS
buildOS -> ErrMsg -> IO TextEncoding
mkTextEncoding ErrMsg
"CP932//TRANSLIT"
      | Bool
otherwise          -> ErrMsg -> IO TextEncoding
mkTextEncoding ErrMsg
"UTF-8//TRANSLIT"

    -- |
    --
    getRunEnv :: IO (Maybe [(ErrMsg, ErrMsg)])
getRunEnv
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ErrMsg ErrMsg
envs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      | Bool
otherwise = do
          [(ErrMsg, ErrMsg)]
curEnvs <- IO [(ErrMsg, ErrMsg)]
S.getEnvironment
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map ErrMsg ErrMsg
envs forall a. [a] -> [a] -> [a]
++ [(ErrMsg, ErrMsg)]
curEnvs


-- |
--  write to ghci.
--
command :: String -> AppContext ()
command :: ErrMsg -> AppContext ()
command ErrMsg
cmd = do
  MVar GHCiProc
mver <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar GHCiProc)
ghciProcAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  GHCiProc
proc <- forall a. IO a -> AppContext a
U.liftIOE forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar GHCiProc
mver
  let hdl :: Handle
hdl = GHCiProc
procforall s a. s -> Getting a s a -> a
^.Lens' GHCiProc Handle
wHdLGHCiProc

  forall a. IO a -> AppContext a
U.liftIOE forall a b. (a -> b) -> a -> b
$ Handle -> ErrMsg -> IO ()
S.hPutStrLn Handle
hdl ErrMsg
cmd
  ErrMsg -> AppContext ()
pout ErrMsg
cmd

  where
    pout :: ErrMsg -> AppContext ()
pout ErrMsg
s
      | forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf ErrMsg
":dap-" ErrMsg
s = ErrMsg -> AppContext ()
U.sendStdoutEventLF forall a b. (a -> b) -> a -> b
$ (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
(/=) Char
' ') ErrMsg
s) forall a. [a] -> [a] -> [a]
++ ErrMsg
" ..."
      | Bool
otherwise = ErrMsg -> AppContext ()
U.sendStdoutEventLF ErrMsg
s


-- |
--
expectInitPmpt :: String -> AppContext [String]
expectInitPmpt :: ErrMsg -> AppContext [ErrMsg]
expectInitPmpt ErrMsg
pmpt = do
  MVar GHCiProc
mvar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar GHCiProc)
ghciProcAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  GHCiProc
proc <- forall a. IO a -> AppContext a
U.liftIOE forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar GHCiProc
mvar
  let hdl :: Handle
hdl = GHCiProc
procforall s a. s -> Getting a s a -> a
^.Lens' GHCiProc Handle
rHdlGHCiProc

  ErrMsg -> Handle -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
go ErrMsg
pmpt Handle
hdl ErrMsg
"" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right ErrMsg
xs -> do
      let strs :: [ErrMsg]
strs = forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> ErrMsg
U.rstrip forall a b. (a -> b) -> a -> b
$ ErrMsg -> [ErrMsg]
lines ErrMsg
xs
      [ErrMsg] -> AppContext ()
pout [ErrMsg]
strs
      forall (m :: * -> *) a. Monad m => a -> m a
return [ErrMsg]
strs
    Left ErrMsg
xs -> do
      let strs :: [ErrMsg]
strs = forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> ErrMsg
U.rstrip forall a b. (a -> b) -> a -> b
$ ErrMsg -> [ErrMsg]
lines ErrMsg
xs
      [ErrMsg] -> AppContext ()
pout [ErrMsg]
strs
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"[CRITICAL] can not get the initial ghci prompt."

  where
    go :: String -> S.Handle -> String -> AppContext (Either String String)
    go :: ErrMsg -> Handle -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
go ErrMsg
key Handle
hdl ErrMsg
acc = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
      (Handle -> AppContext ErrMsg
U.readChar Handle
hdl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrMsg
-> Handle -> ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
byPmpt ErrMsg
key Handle
hdl ErrMsg
acc)
      (ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
errHdl ErrMsg
acc)

    errHdl :: String -> String -> AppContext (Either String String)
    errHdl :: ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
errHdl ErrMsg
acc ErrMsg
e = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> ErrMsg
unlines [ErrMsg
acc, ErrMsg
"", ErrMsg
e, ErrMsg
""]

    byPmpt :: String -> S.Handle -> String -> String -> AppContext (Either String String)
    byPmpt :: ErrMsg
-> Handle -> ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
byPmpt ErrMsg
key Handle
hdl ErrMsg
acc ErrMsg
b = do
      let newAcc :: ErrMsg
newAcc = ErrMsg
acc forall a. [a] -> [a] -> [a]
++ ErrMsg
b
      ErrMsg -> ErrMsg -> AppContext ()
U.debugEV ErrMsg
_LOG_GHCI_STDOUT ErrMsg
newAcc
      if forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
key ErrMsg
newAcc
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ErrMsg
newAcc
        else ErrMsg -> Handle -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
go ErrMsg
key Handle
hdl ErrMsg
newAcc

    pout :: [ErrMsg] -> AppContext ()
pout [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    pout (ErrMsg
x:[]) = ErrMsg -> AppContext ()
U.sendStdoutEvent ErrMsg
x
    pout (ErrMsg
x:[ErrMsg]
xs) = ErrMsg -> AppContext ()
U.sendStdoutEventLF ErrMsg
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ErrMsg] -> AppContext ()
pout [ErrMsg]
xs

-- |
--
expectPmpt :: AppContext [String]
expectPmpt :: AppContext [ErrMsg]
expectPmpt = do
  ErrMsg
pmpt <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores ErrMsg
ghciPmptAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  MVar GHCiProc
mvar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar GHCiProc)
ghciProcAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  GHCiProc
proc <- forall a. IO a -> AppContext a
U.liftIOE forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar GHCiProc
mvar
  let hdl :: Handle
hdl = GHCiProc
procforall s a. s -> Getting a s a -> a
^.Lens' GHCiProc Handle
rHdlGHCiProc
      plen :: Int
plen = forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrMsg
pmpt

  Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
go Int
plen Handle
hdl []

  where
    go :: Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
go Int
plen Handle
hdl [ErrMsg]
acc = forall a. IO a -> AppContext a
U.liftIOE (Handle -> IO Bool
S.hIsEOF Handle
hdl) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ErrMsg]
acc
      Bool
False -> Handle -> AppContext ErrMsg
U.readLine Handle
hdl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
byLine Int
plen Handle
hdl [ErrMsg]
acc

    byLine :: Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
byLine Int
plen Handle
hdl [ErrMsg]
acc ErrMsg
line
      | forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
_DAP_CMD_END2 ErrMsg
line = Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
goEnd Int
plen Handle
hdl [ErrMsg]
acc
      | Bool
otherwise = Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
cont Int
plen Handle
hdl [ErrMsg]
acc ErrMsg
line

    cont :: Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
cont Int
plen Handle
hdl [ErrMsg]
acc ErrMsg
l = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (ErrMsg -> ErrMsg -> Bool
U.startswith ErrMsg
_DAP_HEADER ErrMsg
l)) forall a b. (a -> b) -> a -> b
$ ErrMsg -> AppContext ()
U.sendStdoutEventLF ErrMsg
l
      Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
go Int
plen Handle
hdl forall a b. (a -> b) -> a -> b
$ [ErrMsg]
acc forall a. [a] -> [a] -> [a]
++ [ErrMsg
l]

    goEnd :: Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
goEnd Int
plen Handle
hdl [ErrMsg]
acc = do
      ByteString
b <- forall a. IO a -> AppContext a
U.liftIOE forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
B.hGet Handle
hdl Int
plen
      let l :: ErrMsg
l = ByteString -> ErrMsg
U.bs2str ByteString
b
      ErrMsg -> AppContext ()
U.sendStdoutEvent ErrMsg
l
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ErrMsg]
acc forall a. [a] -> [a] -> [a]
++ [ErrMsg
l]