{-# LANGUAGE LambdaCase #-}

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

---------------------------------------------------------------------------------
-- |
--  run ghci.
--
startGHCi :: String
          -> [String]
          -> FilePath
          -> M.Map String String
          -> AppContext ()
startGHCi :: String -> [String] -> String -> Map String String -> AppContext ()
startGHCi String
cmd [String]
opts String
cwd Map String String
envs =
  IO (Either String GHCiProc) -> AppContext (Either String GHCiProc)
forall a. IO a -> AppContext a
U.liftIOE (String
-> [String]
-> String
-> Map String String
-> IO (Either String GHCiProc)
startGHCiIO String
cmd [String]
opts String
cwd Map String String
envs) AppContext (Either String GHCiProc)
-> (Either String GHCiProc
    -> StateT AppStores (ExceptT String IO) GHCiProc)
-> StateT AppStores (ExceptT String IO) GHCiProc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String GHCiProc
-> StateT AppStores (ExceptT String IO) GHCiProc
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither StateT AppStores (ExceptT String IO) GHCiProc
-> (GHCiProc -> AppContext ()) -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GHCiProc -> AppContext ()
forall (m :: * -> *).
(MonadState AppStores m, MonadIO m) =>
GHCiProc -> m ()
updateGHCi

  where
    updateGHCi :: GHCiProc -> m ()
updateGHCi GHCiProc
proc = do
      MVar GHCiProc
mvar <- Getting (MVar GHCiProc) AppStores (MVar GHCiProc)
-> AppStores -> MVar GHCiProc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar GHCiProc) AppStores (MVar GHCiProc)
Lens' AppStores (MVar GHCiProc)
ghciProcAppStores (AppStores -> MVar GHCiProc) -> m AppStores -> m (MVar GHCiProc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m AppStores
forall s (m :: * -> *). MonadState s m => m s
get
      --_ <- liftIO $ takeMVar mvar
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar GHCiProc -> GHCiProc -> IO ()
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 :: String
-> [String]
-> String
-> Map String String
-> IO (Either String GHCiProc)
startGHCiIO String
cmd [String]
opts String
cwd Map String String
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 (NewlineMode -> IO ()) -> NewlineMode -> IO ()
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 (NewlineMode -> IO ()) -> NewlineMode -> IO ()
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 (NewlineMode -> IO ()) -> NewlineMode -> IO ()
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 (NewlineMode -> IO ()) -> NewlineMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.CRLF Newline
S.LF
  --S.hSetBinaryMode fromGHCiHandle True

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

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

  Either String GHCiProc -> IO (Either String GHCiProc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GHCiProc -> IO (Either String GHCiProc))
-> (GHCiProc -> Either String GHCiProc)
-> GHCiProc
-> IO (Either String GHCiProc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCiProc -> Either String GHCiProc
forall a b. b -> Either a b
Right (GHCiProc -> IO (Either String GHCiProc))
-> GHCiProc -> IO (Either String GHCiProc)
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 OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
buildOS -> String -> IO TextEncoding
mkTextEncoding String
"CP932//TRANSLIT"
      | Bool
otherwise          -> String -> IO TextEncoding
mkTextEncoding String
"UTF-8//TRANSLIT"

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


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

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

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


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

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

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

    errHdl :: String -> String -> AppContext (Either String String)
    errHdl :: String -> String -> AppContext (Either String String)
errHdl String
acc String
e = Either String String -> AppContext (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> AppContext (Either String String))
-> Either String String -> AppContext (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) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
acc, String
"", String
e, String
""]

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

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

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

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

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

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

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

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