Utility.hs

{-# LANGUAGE CPP #-}

module Haskell.Debug.Adapter.Utility where

import Control.Lens
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Conduit.Binary as C
import qualified Data.Conduit as C
import qualified Data.Conduit.List as C
import Control.Monad.Except
import Control.Monad.State.Lazy
import qualified System.IO as S
import qualified System.Process as S
import qualified System.Exit as S
import Control.Concurrent.MVar
import qualified System.Log.Logger as L
import qualified Data.List as L
import qualified Control.Exception.Safe as E

#if __GLASGOW_HASKELL__ >= 906
import Control.Monad
#endif

import qualified Haskell.DAP as DAP
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Constant

-- |
--
str2bs :: String -> BS.ByteString
str2bs = TE.encodeUtf8 . T.pack

-- |
--
bs2str :: BS.ByteString -> String
bs2str = T.unpack. TE.decodeUtf8

-- |
--
str2lbs :: String -> BSL.ByteString
str2lbs = TLE.encodeUtf8 . TL.pack

-- |
--
lbs2str :: BSL.ByteString -> String
lbs2str = TL.unpack. TLE.decodeUtf8


-- |
--
--
loadFile :: FilePath -> IO BS.ByteString
loadFile path = do
  bs <- C.runConduitRes
      $ C.sourceFile path
      C..| C.consume
  return $ BS.concat bs


-- |
--
--
saveFile :: FilePath -> BS.ByteString -> IO ()
saveFile path cont = saveFileBSL path $ BSL.fromStrict cont


-- |
--
--
saveFileBSL :: FilePath -> BSL.ByteString -> IO ()
saveFileBSL path cont = C.runConduitRes
  $ C.sourceLbs cont
  C..| C.sinkFile path


-- |
--
--
add2File :: FilePath -> BS.ByteString -> IO ()
add2File path cont = add2FileBSL path $ BSL.fromStrict cont

-- |
--
--
add2FileBSL :: FilePath -> BSL.ByteString -> IO ()
add2FileBSL path cont = C.runConduitRes
  $ C.sourceLbs cont
  C..| C.sinkIOHandle hdl

  where hdl = S.openFile path S.AppendMode


-- |
--  utility
--
showEE :: (Show e) => Either e a -> Either ErrMsg a
showEE (Right v) = Right v
showEE (Left  e) = Left $ show e


-- |
--
runApp :: AppStores -> AppContext a -> IO (Either ErrMsg (a, AppStores))
runApp dat app = runExceptT $ runStateT app dat


-- |
--
addRequest :: WrapRequest -> AppContext ()
addRequest req = do
  reqsMVar <- view reqStoreAppStores <$> get
  reqs <- liftIO $ takeMVar reqsMVar
  liftIO $ putMVar reqsMVar (reqs++[req])


-- |
--  High priority
--
addRequestHP :: WrapRequest -> AppContext ()
addRequestHP req = do
  reqsMVar <- view reqStoreAppStores <$> get
  reqs <- liftIO $ takeMVar reqsMVar
  liftIO $ putMVar reqsMVar (req:reqs)


-- |
--
addResponse :: Response -> AppContext ()
addResponse res = do
  appData <- get
  let mvar = appData^.resStoreAppStores
  ress <- liftIO $ takeMVar mvar
  liftIO $ putMVar mvar (ress++[res])


-- |
--
getIncreasedResponseSequence :: AppContext Int
getIncreasedResponseSequence = do
  appData <- get
  let cnt = appData^.resSeqAppStores
      seq = 1 + cnt
  put appData {_resSeqAppStores = seq}
  return seq

-- |
--
sendConsoleEvent :: String -> AppContext ()
sendConsoleEvent = sendOutputEventWithType "console"

-- |
--
sendConsoleEventLF :: String -> AppContext ()
sendConsoleEventLF x = sendConsoleEvent (x ++ _LF_STR)


-- |
--
sendStdoutEvent :: String -> AppContext ()
sendStdoutEvent = sendOutputEventWithType "stdout"


-- |
--
sendStdoutEventLF :: String -> AppContext ()
sendStdoutEventLF x = sendStdoutEvent (x ++ _LF_STR)


-- |
--
sendErrorEvent :: String -> AppContext ()
sendErrorEvent = sendOutputEventWithType "stderr"

-- |
--
sendErrorEventLF :: String -> AppContext ()
sendErrorEventLF x = sendErrorEvent (x ++ _LF_STR)


-- |
--
sendOutputEventWithType :: String -> String -> AppContext ()
sendOutputEventWithType evType msg = do
  resSeq <- getIncreasedResponseSequence
  let body = DAP.OutputEventBody evType msg Nothing
      outEvt = DAP.defaultOutputEvent {
                DAP.seqOutputEvent = resSeq
              , DAP.bodyOutputEvent = body
              }

  addResponse $ OutputEvent outEvt

-- |
--
debugEV :: String -> String -> AppContext ()
debugEV name msg = do
  liftIO $ L.debugM name msg
  logEV L.DEBUG name msg

-- |
--
infoEV :: String -> String -> AppContext ()
infoEV name msg = do
  liftIO $ L.infoM name msg
  logEV L.INFO name msg

-- |
--
warnEV :: String -> String -> AppContext ()
warnEV name msg = do
  liftIO $ L.warningM name msg
  logEV L.WARNING name msg

-- |
--
errorEV :: String -> String -> AppContext ()
errorEV name msg = do
  liftIO $ L.errorM name msg
  logEV L.ERROR name msg

-- |
--
criticalEV :: String -> String -> AppContext ()
criticalEV name msg = do
  liftIO $ L.criticalM name msg
  logEV L.CRITICAL name msg

-- |
--
logEV :: L.Priority -> String -> String -> AppContext ()
logEV pr name msg = do
  mvar <- view logPriorityAppStores <$> get
  logPR <- liftIO $ readMVar mvar
  let msg' = if L.isSuffixOf _LF_STR msg then msg else msg ++ _LF_STR

  when (pr >= logPR) $ do
    sendStdoutEvent $ "[" ++ show pr ++ "][" ++ name ++ "] " ++ msg'



-- |
--
sendPauseResponse :: DAP.PauseRequest -> AppContext ()
sendPauseResponse req = do
  resSeq <- getIncreasedResponseSequence

  let res = DAP.defaultPauseResponse {
            DAP.seqPauseResponse         = resSeq
          , DAP.request_seqPauseResponse = DAP.seqPauseRequest req
          , DAP.successPauseResponse     = False
          , DAP.messagePauseResponse     = "pause request is not supported."
          }

  addResponse $ PauseResponse res


-- |
--
--   phoityne -> haskell-dap
--   encoding RequestArgument to [Word8] because of using ghci command line interface.
--
showDAP :: Show a => a -> String
showDAP = show . BS.unpack . TE.encodeUtf8 . T.pack . show


-- |
--
sendTerminatedEvent :: AppContext ()
sendTerminatedEvent = do
  resSeq <- getIncreasedResponseSequence
  let evt = DAP.defaultTerminatedEvent {
            DAP.seqTerminatedEvent = resSeq
          }

  addResponse $ TerminatedEvent evt


-- |
--
sendRestartEvent :: AppContext ()
sendRestartEvent = do
  resSeq <- getIncreasedResponseSequence
  let evt = DAP.defaultTerminatedEvent {
            DAP.seqTerminatedEvent = resSeq
          , DAP.bodyTerminatedEvent = DAP.defaultTerminatedEventBody {
              DAP.restartTerminatedEventBody = True
            }
          }

  addResponse $ TerminatedEvent evt



-- |
--
sendExitedEvent :: AppContext ()
sendExitedEvent = do
  code <- getExitCode
  resSeq <- getIncreasedResponseSequence
  let evt = DAP.defaultExitedEvent {
            DAP.seqExitedEvent = resSeq
          , DAP.bodyExitedEvent = DAP.defaultExitedEventBody {
                DAP.exitCodeExitedEventBody = code
              }
          }

  addResponse $ ExitedEvent evt

  where
    getExitCode = getGHCiExitCode >>= \case
      Just c -> return c
      Nothing -> do
        liftIO $ L.infoM _LOG_NAME "force kill ghci."
        force

    force = killGHCi >> getGHCiExitCode >>= \case
      Just c -> return c
      Nothing -> do
        liftIO $ L.infoM _LOG_NAME "force kill ghci failed."
        return 1  -- kill ghci failed. error exit anyway.

-- |
--
getGHCiExitCode :: AppContext (Maybe Int)
getGHCiExitCode = do
  procMVar <- view ghciProcAppStores <$> get
  proc <- liftIO $ readMVar procMVar
  liftIO (S.getProcessExitCode (proc^.procGHCiProc)) >>= \case
    Just S.ExitSuccess -> return $ Just 0
    Just (S.ExitFailure c) -> return $ Just c
    Nothing -> return Nothing

-- |
--   On Windows, terminateProcess blocks for exiting.
--
killGHCi :: AppContext ()
killGHCi = do
  return ()
  {-
  procMVar <- view ghciProcAppStores <$> get
  proc <- liftIO $ readMVar procMVar
  liftIO $ S.terminateProcess (proc^.procGHCiProc)
  -}

-- |
--
handleStoppedEventBody :: DAP.StoppedEventBody -> AppContext ()
handleStoppedEventBody body
  | "complete" == DAP.reasonStoppedEventBody body = do
      sendConsoleEventLF "debugging completed. "
      isReRun <- view debugReRunableAppStores <$> get
      handleReRun isReRun
  | otherwise = sendStoppedEvent

  where
    handleReRun True = do
      -- ghci and vscode can not rerun debugging without restart.
      -- sendContinuedEvent
      -- sendPauseEvent
      addRequestHP $ WrapRequest
                   $ InternalTransitRequest
                   $ HdaInternalTransitRequest DebugRun_Contaminated

    handleReRun False = do
      addRequestHP $ WrapRequest
                   $ InternalTerminateRequest
                   $ HdaInternalTerminateRequest ""

    sendStoppedEvent = do
      resSeq <- getIncreasedResponseSequence
      let res = DAP.defaultStoppedEvent {
                DAP.seqStoppedEvent = resSeq
              , DAP.bodyStoppedEvent = body
              }

      addResponse $ StoppedEvent res

{-
    sendContinuedEvent = do
      resSeq <- getIncreasedResponseSequence
      let res = DAP.defaultContinuedEvent {
                DAP.seqContinuedEvent = resSeq
              }

      addResponse $ ContinuedEvent res

    sendPauseEvent = do
      resSeq <- getIncreasedResponseSequence
      let res = DAP.defaultStoppedEvent {
                DAP.seqStoppedEvent = resSeq
              , DAP.bodyStoppedEvent = DAP.defaultStoppedEventBody {
                  DAP.reasonStoppedEventBody = "pause"
                }
              }

      addResponse $ StoppedEvent res
-}

-- |
--
readLine :: S.Handle -> AppContext String
readLine hdl =   isOpenHdl hdl
             >>= isReadableHdl
             >>= isNotEofHdl
             >>= go

  where
    go hdl = liftIOE $ S.hGetLine hdl


-- |
--
readChar :: S.Handle -> AppContext String
readChar hdl = isOpenHdl hdl
           >>= isReadableHdl
           >>= isNotEofHdl
           >>= go
           >>= toString
           >>= isNotEmpty

  where
    go hdl = liftIOE $ S.hGetChar hdl

    toString c = return [c]


-- |
--
readCharL :: S.Handle -> AppContext BSL.ByteString
readCharL hdl = readCharsL hdl 1


-- |
--
readCharsL :: S.Handle -> Int -> AppContext BSL.ByteString
readCharsL hdl c = isOpenHdl hdl
               >>= isReadableHdl
               >>= isNotEofHdl
               >>= go
               >>= isNotEmptyL

  where
    go hdl = liftIOE $ BSL.hGet hdl c


-- |
--
isOpenHdl :: S.Handle -> AppContext S.Handle
isOpenHdl rHdl = liftIOE (S.hIsOpen rHdl) >>= \case
  True  -> return rHdl
  False -> throwError "invalid HANDLE. not opened."


-- |
--
isReadableHdl :: S.Handle -> AppContext S.Handle
isReadableHdl rHdl = liftIOE (S.hIsReadable rHdl) >>= \case
  True  -> return rHdl
  False -> throwError "invalid HANDLE. not readable."


-- |
--
isNotEofHdl :: S.Handle -> AppContext S.Handle
isNotEofHdl rHdl = liftIOE (S.hIsEOF rHdl) >>= \case
  False -> return rHdl
  True  -> throwError "invalid HANDLE. eof."


-- |
--
isNotEmpty :: String -> AppContext String
isNotEmpty b
  | null b = throwError "empty input."
  | otherwise = return b


-- |
--
isNotEmptyL :: BSL.ByteString -> AppContext BSL.ByteString
isNotEmptyL b
  | b == BSL.empty = throwError "empty input."
  | otherwise = return b


-- |
--
addEvent :: Event -> AppContext ()
addEvent evt = do
  mvar <- view eventStoreAppStores <$> get
  evts <- liftIO $ takeMVar mvar
  liftIO $ putMVar mvar (evts++[evt])


-- |
--
liftIOE :: IO a -> AppContext a
liftIOE f = liftIO (go f) >>= liftEither
  where
    go :: IO b -> IO (Either String b)
    go f = E.catchAny (Right <$> f) errHdl

    errHdl :: E.SomeException -> IO (Either String a)
    errHdl = return . Left . show


-- |
--
rstrip :: String -> String
rstrip = T.unpack . T.stripEnd . T.pack


-- |
--
strip :: String -> String
strip = T.unpack . T.strip . T.pack

-- |
--
replace :: String -> String -> String -> String
replace a b c = T.unpack $ T.replace (T.pack a) (T.pack b) (T.pack c)

-- |
--
split :: String -> String -> [String]
split a b = map T.unpack $ T.splitOn (T.pack a) (T.pack b)

-- |
--
join :: String -> [String] -> String
join a b = T.unpack $ T.intercalate (T.pack a) $ map T.pack b

-- |
--
startswith :: String -> String -> Bool
startswith a b = T.isPrefixOf (T.pack a) (T.pack b)


-- |
--
stdioLogging :: BSL.ByteString -> AppContext ()
stdioLogging bs = do
  logFile <- view stdioLogFileAppStores <$> get
  go logFile

  where
    go :: Maybe FilePath -> AppContext ()
    go Nothing  = return ()
    go (Just f) = liftIOE $ BSL.appendFile f bs


-- |
--
stdinLogging :: BSL.ByteString -> AppContext ()
stdinLogging bs = do
  stdioLogging $ str2lbs "[ IN]" `BSL.append` bs `BSL.append` str2lbs "\n"


-- |
--
stdoutLogging :: BSL.ByteString -> AppContext ()
stdoutLogging bs = do
  stdioLogging $ str2lbs "[OUT]" `BSL.append` bs `BSL.append` str2lbs "\n"