content: {-# 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 cmd opts cwd envs =
    U.liftIOE (startGHCiIO cmd opts cwd envs) >>= liftEither >>= updateGHCi
  
    where
      updateGHCi proc = do
        mvar <- view ghciProcAppStores <$> get
        --_ <- liftIO $ takeMVar mvar
        liftIO $ putMVar mvar proc
  
  
  -- |
  --
  startGHCiIO :: String
              -> [String]
              -> FilePath
              -> M.Map String String
              -> IO (Either ErrMsg GHCiProc)
  startGHCiIO cmd opts cwd envs = do
  
    (fromPhoityneHandle, toGHCiHandle) <- S.createPipe
    (fromGHCiHandle, toPhoityneHandle) <- S.createPipe
  
    osEnc <- getReadHandleEncoding
  
    let bufMode = S.NoBuffering
    --let bufMode = S.BlockBuffering $ Just 1024
  
    S.hSetBuffering toPhoityneHandle bufMode
    S.hSetEncoding toPhoityneHandle osEnc
    S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF
    --S.hSetBinaryMode toPhoityneHandle True
  
    S.hSetBuffering fromPhoityneHandle bufMode
    S.hSetEncoding fromPhoityneHandle  S.utf8
    S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF
    --S.hSetBinaryMode fromPhoityneHandle True
  
    S.hSetBuffering toGHCiHandle bufMode
    S.hSetEncoding toGHCiHandle S.utf8
    S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF
    --S.hSetBinaryMode toGHCiHandle True
  
    S.hSetBuffering fromGHCiHandle bufMode
    S.hSetEncoding fromGHCiHandle osEnc
    S.hSetNewlineMode fromGHCiHandle $ S.NewlineMode S.CRLF S.LF
    --S.hSetBinaryMode fromGHCiHandle True
  
    runEnvs <- getRunEnv
  
    ghciGHCi <- S.runProcess cmd opts (Just cwd) runEnvs (Just fromPhoityneHandle) (Just toPhoityneHandle) (Just toPhoityneHandle)
  
    return . Right $ GHCiProc toGHCiHandle fromGHCiHandle fromGHCiHandle ghciGHCi
  
    where
      -- |
      --
      getReadHandleEncoding :: IO TextEncoding
      getReadHandleEncoding = if
        | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT"
        | otherwise          -> mkTextEncoding "UTF-8//TRANSLIT"
  
      -- |
      --
      getRunEnv
        | null envs = return Nothing
        | otherwise = do
            curEnvs <- S.getEnvironment
            return $ Just $ M.toList envs ++ curEnvs
  
  
  -- |
  --  write to ghci.
  --
  command :: String -> AppContext ()
  command cmd = do
    mver <- view ghciProcAppStores <$> get
    proc <- U.liftIOE $ readMVar mver
    let hdl = proc^.wHdLGHCiProc
  
    U.liftIOE $ S.hPutStrLn hdl cmd
    pout cmd
  
    where
      pout s
        | L.isPrefixOf ":dap-" s = U.sendStdoutEventLF $ (takeWhile ((/=) ' ') s) ++ " ..."
        | otherwise = U.sendStdoutEventLF s
  
  
  -- |
  --
  expectInitPmpt :: String -> AppContext [String]
  expectInitPmpt pmpt = do
    mvar <- view ghciProcAppStores <$> get
    proc <- U.liftIOE $ readMVar mvar
    let hdl = proc^.rHdlGHCiProc
  
    go pmpt hdl "" "" >>= \case
      Right xs -> do
        let strs = map U.rstrip $ lines xs
        -- pout strs
        return strs
      Left xs -> do
        let strs = map U.rstrip $ lines xs
        pout strs
        throwError "[CRITICAL] can not get the initial ghci prompt."
  
    where
      go :: String -> S.Handle -> String -> String -> AppContext (Either String String)
      go key hdl acc accL = catchError
        (U.readChar hdl >>= byPmpt key hdl acc accL)
        (errHdl acc)
  
      errHdl :: String -> String -> AppContext (Either String String)
      errHdl acc e = return $ Left $ unlines [acc, "", e, ""]
  
      byPmpt :: String -> S.Handle -> String -> String -> String -> AppContext (Either String String)
      byPmpt key hdl acc accL b = do
        let newAcc = acc ++ b
        let newAccL = accL ++ b
  
        if _LF_STR == b
          then do
            U.sendStdoutEventLF accL
            go key hdl newAcc ""
          else if L.isSuffixOf key newAcc
              then do
                U.sendStdoutEvent newAccL
                return $ Right newAcc
              else go key hdl newAcc newAccL
  
      pout [] = return ()
      pout (x:[]) = U.sendStdoutEvent x
      pout (x:xs) = U.sendStdoutEventLF x >> pout xs
  
  -- |
  --
  expectPmpt :: AppContext [String]
  expectPmpt = do
    pmpt <- view ghciPmptAppStores <$> get
    mvar <- view ghciProcAppStores <$> get
    proc <- U.liftIOE $ readMVar mvar
    let hdl = proc^.rHdlGHCiProc
        plen = length pmpt
  
    go plen hdl []
  
    where
      go plen hdl acc = U.liftIOE (S.hIsEOF hdl) >>= \case
        True  -> return acc
        False -> U.readLine hdl >>= byLine plen hdl acc
  
      byLine plen hdl acc line
        | L.isSuffixOf _DAP_CMD_END2 line = goEnd plen hdl acc
        | otherwise = cont plen hdl acc line
  
      cont plen hdl acc l = do
        when (not (U.startswith _DAP_HEADER l)) $ U.sendStdoutEventLF l
        go plen hdl $ acc ++ [l]
  
      goEnd plen hdl acc = do
        b <- U.liftIOE $ B.hGet hdl plen
        let l = U.bs2str b
        U.sendStdoutEvent l
        return $ acc ++ [l]
  
  