packages feed

haskell-debug-adapter (empty) → 0.0.29.0

raw patch · 41 files changed

+5144/−0 lines, 41 filesdep +Cabaldep +MissingHdep +aesonsetup-changed

Dependencies added: Cabal, MissingH, aeson, async, base, bytestring, clock, cmdargs, conduit, conduit-extra, containers, data-default, directory, filepath, fsnotify, haskell-dap, haskell-debug-adapter, hslogger, hspec, lens, mtl, parsec, process, resourcet, safe-exceptions, text

Files

+ Changelog.md view
@@ -0,0 +1,6 @@+++20190301 haskell-debug-adapter-0.0.29.0+  * [INFO] start developping, based on phoityne-vscode-0.0.28.0.++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,45 @@++# HDA : Haskell Debug Adapter++A [debug adapter](https://microsoft.github.io/debug-adapter-protocol/) for Haskell debugging system.++![101_deploy.png](https://raw.githubusercontent.com/phoityne/haskell-debug-adapter/master/docs/design/101_deploy.png)++Started developing based on [phoityne-vscode-0.0.28.0](https://hackage.haskell.org/package/phoityne-vscode).  +Changed package name (because a name "phoityne-vscode" is ambiguous.), and with some refactoring.++# Requirement+  - haskell-dap+  - ghci-dap++```+> stack install haskell-dap ghci-dap haskell-debug-adapter+```+++# Limitation+Currently this project is an __experimental__ design and implementation.++* Dev and checked on windows10 ghc-8.4+* The source file extension must be ".hs"+* Can not use STDIN handle while debugging. +++# Configuration++## launch.json++|NAME|REQUIRED OR OPTIONAL|DEFAULT SETTING|DESCRIPTION|+|:--|:--:|:--|:--|+|startup|required|${workspaceRoot}/test/Spec.hs|debug startup file, will be loaded automatically.|+|startupFunc|optional|"" (empty string)|debug startup function, will be run instead of main function.|+|startupArgs|optional|"" (empty string)|arguments for startup function. set as string type.|+|ghciCmd|required|stack ghci __--with-ghc=ghci-dap__ --test --no-load --no-build --main-is TARGET --ghci-options -fprint-evld-with-show|launch ghci command, must be Prelude module loaded. For example, "ghci -i${workspaceRoot}/src", "cabal exec -- ghci -i${workspaceRoot}/src"|+|ghciPrompt|required|H>>=|ghci command prompt string.|+|ghciInitialPrompt|optional|"Prelude> "|initial pormpt of ghci. set it when using custom prompt. e.g. set in .ghci|+|stopOnEntry|required|false|stop or not after debugger launched.+|mainArgs|optional|"" (empty string)|main arguments.|+|logFile|required|${workspaceRoot}/.vscode/phoityne.log|internal log file.|+|logLevel|required|WARNING|internal log level.|++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Haskell/Debug/Adapter/Argument.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-cse #-}++module Haskell.Debug.Adapter.Argument (+  setting+) where++import Paths_haskell_debug_adapter (version)+import Data.Version (showVersion)+import System.Console.CmdArgs++import Haskell.Debug.Adapter.Control++-- |+--  Annotation Setting+--+setting :: ArgData+setting = modes [mode]+  &= summary summaryMsg+  &= program "haskell-debug-adapter"+         +  where+    mode = ArgData {+        _hackageVersionArgData = showVersion version+          &= name "hackage-version"+          &= typ "VERSION"+          &= explicit+          &= help "hackage module version."+      } &= name "Mode"+        &= details detailMsg+        &= auto++    summaryMsg = unlines [+        ""+      , "VERSION: haskell-debug-adapter-" ++ showVersion version+      , ""+      ]+           +    detailMsg = [+        ""+      , "  DESCRIPTION: ... "+      , ""+      , "     Please see README.md"+      , ""+      ]+
+ app/Haskell/Debug/Adapter/Main.hs view
@@ -0,0 +1,30 @@+module Haskell.Debug.Adapter.Main (run) where++import qualified System.IO as S+import qualified Control.Exception.Safe as E++import qualified Haskell.Debug.Adapter.Control as CTRL++++-- |+--  Application Main+-- +run :: CTRL.ArgData -> IO Int+run args = flip E.catchAny ehdl $ do++  -- run logic main+  flip E.finally finalize $ CTRL.run args S.stdin S.stdout++  where+    finalize = return () +    ehdl e   = putStrLn (criticalMsg e) >> return 1++    criticalMsg e = unlines [+        ""+      , "[CRITICAL] unexpected error. exit 1."+      , "--------------------------------------------------------------------------------"+      , show e+      , "--------------------------------------------------------------------------------"+      ]+
+ app/Main.hs view
@@ -0,0 +1,17 @@+module Main where++import System.Exit+import qualified Haskell.Debug.Adapter.Main as M++import qualified Haskell.Debug.Adapter.Argument as A+import qualified System.Console.CmdArgs as CMD++-- |+--  Main+--+main :: IO ()+main = CMD.cmdArgs A.setting >>= M.run >>= \case+  0 -> exitSuccess+  c -> exitWith . ExitFailure $ c++
+ haskell-debug-adapter.cabal view
@@ -0,0 +1,173 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 791ada16dd7af898ca59de433a41178ba2a929d17d295460fedef363b7435edb++name:           haskell-debug-adapter+version:        0.0.29.0+synopsis:       Haskell Debug Adapter.+description:    Please see README.md+category:       Development+homepage:       https://github.com/phoityne/haskell-debug-adapter/+bug-reports:    https://github.com/phoityne/haskell-debug-adapter/issues+author:         phoityne_hs+maintainer:     phoityne.hs@gmail.com+copyright:      2016-2019 phoityne_hs+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    Changelog.md++library+  exposed-modules:+      Haskell.Debug.Adapter.Control+  other-modules:+      Haskell.Debug.Adapter.Application+      Haskell.Debug.Adapter.Constant+      Haskell.Debug.Adapter.GHCi+      Haskell.Debug.Adapter.Logger+      Haskell.Debug.Adapter.Request+      Haskell.Debug.Adapter.Response+      Haskell.Debug.Adapter.State.Contaminated+      Haskell.Debug.Adapter.State.DebugRun+      Haskell.Debug.Adapter.State.DebugRun.Continue+      Haskell.Debug.Adapter.State.DebugRun.InternalTerminate+      Haskell.Debug.Adapter.State.DebugRun.Next+      Haskell.Debug.Adapter.State.DebugRun.Scopes+      Haskell.Debug.Adapter.State.DebugRun.StackTrace+      Haskell.Debug.Adapter.State.DebugRun.StepIn+      Haskell.Debug.Adapter.State.DebugRun.Terminate+      Haskell.Debug.Adapter.State.DebugRun.Threads+      Haskell.Debug.Adapter.State.DebugRun.Variables+      Haskell.Debug.Adapter.State.GHCiRun+      Haskell.Debug.Adapter.State.GHCiRun.ConfigurationDone+      Haskell.Debug.Adapter.State.Init+      Haskell.Debug.Adapter.State.Init.Initialize+      Haskell.Debug.Adapter.State.Init.Launch+      Haskell.Debug.Adapter.State.Shutdown+      Haskell.Debug.Adapter.State.Utility+      Haskell.Debug.Adapter.TH.Utility+      Haskell.Debug.Adapter.Thread+      Haskell.Debug.Adapter.Type+      Haskell.Debug.Adapter.Utility+      Haskell.Debug.Adapter.Watch+      Paths_haskell_debug_adapter+  hs-source-dirs:+      src+  default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-orphans -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      Cabal+    , MissingH+    , aeson+    , async+    , base >=4.7 && <5+    , bytestring+    , clock+    , cmdargs+    , conduit+    , conduit-extra+    , containers+    , data-default+    , directory+    , filepath+    , fsnotify+    , haskell-dap >=0.0.12.0+    , hslogger+    , lens+    , mtl+    , parsec+    , process+    , resourcet+    , safe-exceptions+    , text+  if impl(ghc < 8.4.0)+    buildable: False+  default-language: Haskell2010++executable haskell-debug-adapter+  main-is: Main.hs+  other-modules:+      Haskell.Debug.Adapter.Argument+      Haskell.Debug.Adapter.Main+      Paths_haskell_debug_adapter+  hs-source-dirs:+      app+  default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-orphans -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      Cabal+    , MissingH+    , aeson+    , async+    , base >=4.7 && <5+    , bytestring+    , clock+    , cmdargs+    , conduit+    , conduit-extra+    , containers+    , data-default+    , directory+    , filepath+    , fsnotify+    , haskell-dap >=0.0.12.0+    , haskell-debug-adapter+    , hslogger+    , lens+    , mtl+    , parsec+    , process+    , resourcet+    , safe-exceptions+    , text+  if impl(ghc < 8.4.0)+    buildable: False+  default-language: Haskell2010++test-suite haskell-debug-adapter-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Haskell.Debug.Adapter.ControlSpec+      Spec.Utility+      Paths_haskell_debug_adapter+  hs-source-dirs:+      test+  default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-orphans -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      Cabal+    , MissingH+    , aeson+    , async+    , base >=4.7 && <5+    , bytestring+    , clock+    , cmdargs+    , conduit+    , conduit-extra+    , containers+    , data-default+    , directory+    , filepath+    , fsnotify+    , haskell-dap >=0.0.12.0+    , haskell-debug-adapter+    , hslogger+    , hspec+    , lens+    , mtl+    , parsec+    , process+    , resourcet+    , safe-exceptions+    , text+  if impl(ghc < 8.4.0)+    buildable: False+  default-language: Haskell2010
+ src/Haskell/Debug/Adapter/Application.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE LambdaCase #-}++module Haskell.Debug.Adapter.Application where++import Paths_haskell_debug_adapter (version)+import Data.Version (showVersion)+import Control.Monad.IO.Class+import Data.Conduit+import Control.Lens+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar+import Control.Monad.State.Lazy+import Control.Monad.Except+import qualified System.Log.Logger as L+import qualified System.IO as S++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant+import Haskell.Debug.Adapter.State.Init()+import Haskell.Debug.Adapter.State.GHCiRun()+import Haskell.Debug.Adapter.State.DebugRun()+import Haskell.Debug.Adapter.State.Shutdown()+import Haskell.Debug.Adapter.State.Contaminated()+++-- |+-- +defaultAppStores :: S.Handle -> S.Handle -> IO AppStores+defaultAppStores inHdl outHdl = do+  reqStore <- newMVar []+  resStore <- newMVar []+  evtStore <- newMVar []+  wsStore  <- newMVar ""+  logPRStore <- newMVar L.WARNING+  procStore <- newEmptyMVar+  verStore <- newEmptyMVar+  return AppStores {+    -- Read Only+      _appNameAppStores     = "haskell-debug-adapter"+    , _appVerAppStores      = showVersion version+    , _inHandleAppStores    = inHdl+    , _outHandleAppStores   = outHdl+    , _asyncsAppStores      = []++    -- Read/Write from Application+    , _appStateWAppStores   = WrapAppState InitState+    , _resSeqAppStores      = 0+    , _startupAppStores     = ""+    , _startupFuncAppStores = ""+    , _startupArgsAppStores = ""+    , _stopOnEntryAppStores = False+    , _ghciPmptAppStores    = _GHCI_PROMPT_HDA+    , _mainArgsAppStores    = ""+    , _launchReqSeqAppStores = -1+    , _debugReRunableAppStores = False+++    -- Read/Write ASync+    , _reqStoreAppStores    = reqStore+    , _resStoreAppStores    = resStore+    , _eventStoreAppStores  = evtStore+    , _workspaceAppStores   = wsStore+    , _logPriorityAppStores = logPRStore+    , _ghciProcAppStores    = procStore+    , _ghciVerAppStores     = verStore+    }+++-- |+--+run :: AppStores -> IO ()+run appData = do+  L.debugM _LOG_APP "satrt application app"+  runApp appData app+  L.debugM _LOG_APP "end application app"+++-- |+--+app :: AppContext ()+app = flip catchError errHdl $ do+  _ <- runConduit pipeline+  return ()++  where+    pipeline :: ConduitM () Void AppContext ()+    pipeline = src .| sink++    errHdl msg = do+      criticalEV _LOG_APP msg+      addEvent CriticalExitEvent++----------------------------------------------------------------+-- |+--+src :: ConduitT () WrapRequest AppContext ()+src = do+  liftIO $ L.debugM _LOG_APP $ "src start waiting."+  req <- lift goApp+  yield req+  src++  where+    goApp :: AppContext WrapRequest+    goApp = do+      mvar <- view reqStoreAppStores <$> get+      liftIO (takeRequest mvar) >>= \case+        Just res -> return res+        Nothing -> do+          liftIO $ threadDelay _1_MILLI_SEC+          goApp++-- |+--+takeRequest :: MVar [WrapRequest] -> IO (Maybe WrapRequest)+takeRequest reqsMVar = isExists >>= \case+    False -> return Nothing+    True  -> take1++  where+    isExists = readMVar reqsMVar >>= \case+      [] -> return False+      _  -> return True++    take1 = takeMVar reqsMVar >>= \case+      [] -> do+        putMVar reqsMVar []+        return Nothing+      (x:xs) -> do+        putMVar reqsMVar xs+        return $ Just x+++------------------------------------------------------------------------+-- |+--+sink :: ConduitT WrapRequest Void AppContext ()+sink = do+  liftIO $ L.debugM _LOG_APP $ "sink start waiting."+  await >>= \case+    Nothing  -> do+      throwError $ "[CRITICAL][response][sink] unexpectHed Nothing."+      return ()+    Just (WrapRequest (DisconnectRequest req)) -> do+      liftIO $ L.debugM _LOG_APP $ show req+      liftIO $ L.infoM _LOG_APP $ "disconnect. end of application thread."+      lift $ sendDisconnectResponse req+    Just (WrapRequest (PauseRequest req)) -> do+      liftIO $ L.debugM _LOG_APP $ show req+      lift $ sendConsoleEventLF $ "pause request is not supported."+      lift $ sendPauseResponse req+      sink+    Just req -> do+      lift $ appMain req+      sink+++------------------------------------------------------------------------+-- |+--+appMain :: WrapRequest -> AppContext ()+appMain (WrapRequest (InternalTransitRequest (HdaInternalTransitRequest s))) = transit s+appMain reqW = do+  stateW <- view appStateWAppStores <$> get+  +  getStateRequestW stateW reqW >>= actionW >>= \case+    Nothing -> return ()+    Just st -> transit st++-- |+--+transit :: StateTransit -> AppContext ()+transit st = actExitState+          >> updateState st+          >> actEntryState+           +  where+    actExitState = do+      stateW <- view appStateWAppStores <$> get+      exitActionW stateW++    actEntryState = do+      stateW <- view appStateWAppStores <$> get+      entryActionW stateW+++-- |+--+updateState :: StateTransit -> AppContext ()+updateState Init_GHCiRun          = changeState $ WrapAppState GHCiRunState+updateState Init_Shutdown         = changeState $ WrapAppState ShutdownState+updateState GHCiRun_DebugRun      = changeState $ WrapAppState DebugRunState+updateState GHCiRun_Contaminated  = changeState $ WrapAppState ContaminatedState+updateState GHCiRun_Shutdown      = changeState $ WrapAppState ShutdownState+updateState DebugRun_Contaminated = changeState $ WrapAppState ContaminatedState+updateState DebugRun_Shutdown     = changeState $ WrapAppState ShutdownState+updateState DebugRun_GHCiRun      = changeState $ WrapAppState GHCiRunState+updateState Contaminated_Shutdown = changeState $ WrapAppState ShutdownState+++-- |+--+changeState :: WrapAppState -> AppContext ()+changeState s = modify $ \d -> d {_appStateWAppStores = s}++
+ src/Haskell/Debug/Adapter/Constant.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}++module Haskell.Debug.Adapter.Constant where++import qualified Data.Version as V++-- |+--+_INI_SEC_DEF :: String+_INI_SEC_DEF = "DEFAULT"++-- |+--+_INI_DEF_WORK_DIR :: String+_INI_DEF_WORK_DIR  = "work_dir"++-- |+--+_INI_SEC_LOG :: String+_INI_SEC_LOG   = "LOG"++-- |+--+_INI_LOG_FILE :: String+_INI_LOG_FILE  = "file"++-- |+--+_INI_LOG_LEVEL :: String+_INI_LOG_LEVEL = "level"++-- |+--+_LOG_NAME :: String+_LOG_NAME = "HDA"+++-- |+--+_LOG_REQUEST :: String+_LOG_REQUEST = "REQUEST"+++-- |+--+_LOG_RESPONSE :: String+_LOG_RESPONSE = "RESPONSE"+++-- |+--+_LOG_APP :: String+_LOG_APP = "APP"+++-- |+--+_LOG_THREAD_MGR :: String+_LOG_THREAD_MGR = "THREAD_MGR"+++-- |+--+_LOG_EVENT :: String+_LOG_EVENT = "EVENT"+++-- |+--+_LOG_GHCI_STDOUT :: String+_LOG_GHCI_STDOUT = "GHCI_STDOUT"+++-- |+--+_LOG_WATCH :: String+_LOG_WATCH = "WATCH"+++-- |+--+_LOG_FORMAT :: String+_LOG_FORMAT = "$time [$pid($tid)] $prio $loggername - $msg"++-- |+--+_LOG_FORMAT_DATE :: String+_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S.%q"+-- _LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S"+++-- |+-- +_CONTENT_LENGTH :: String+_CONTENT_LENGTH = "Content-Length: " +++-- |+--+_TWO_CRLF :: String+_TWO_CRLF = "\r\n\r\n"++-- |+--+_1_MILLI_SEC :: Int+_1_MILLI_SEC = 1 * 1000++-- |+--+_10_MILLI_SEC :: Int+_10_MILLI_SEC = 10 * 1000+++-- |+--+_100_MILLI_SEC :: Int+_100_MILLI_SEC = 100 * 1000+++-- |+--+_1_SEC :: Int+_1_SEC = 1000 * 1000++-- |+--+--+_SEP_WIN :: Char+_SEP_WIN = '\\'++-- |+--+--+_SEP_UNIX :: Char+_SEP_UNIX = '/'++-- |+--+_GHCI_PROMPT :: String+_GHCI_PROMPT = "Prelude> "++-- |+--+_GHCI_PROMPT_HDA :: String+_GHCI_PROMPT_HDA = "H>>= "+++-- |+--+--_LF_WORD :: Word8+--_LF_WORD = '\n'++-- |+--+_LF_STR :: String+_LF_STR = "\n"+++-- |+--+_BASE_GHCI_VERSION :: V.Version+_BASE_GHCI_VERSION =  V.Version [8, 0, 0] []+++-- |+--+_DAP_HEADER :: String+_DAP_HEADER = "<<DAP>>"+++-- |+--+_DAP_HEADER_OUTPUT_EVENT :: String+_DAP_HEADER_OUTPUT_EVENT = "<<DAP_OUTPUT_EVENT>>"+++-- |+--+_DAP_CMD_END2 :: String+_DAP_CMD_END2 = "<<DAP_CMD_END2>>"+++-- |+--+_HS_FILE_EXT :: String+_HS_FILE_EXT = ".hs"
+ src/Haskell/Debug/Adapter/Control.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE TemplateHaskell #-}++module Haskell.Debug.Adapter.Control where++import System.IO+import Data.Data+import Data.Default+import Control.Lens+import Data.Aeson.TH+import qualified System.Log.Logger as L+import qualified Control.Exception.Safe as E+import Control.Concurrent.Async++import Haskell.Debug.Adapter.Constant+--import Haskell.Debug.Adapter.Type+--import Haskell.Debug.Adapter.Logger+import qualified Haskell.Debug.Adapter.Application as A+import qualified Haskell.Debug.Adapter.Request as RQ+import qualified Haskell.Debug.Adapter.Response as RP+import qualified Haskell.Debug.Adapter.Thread as TD+import qualified Haskell.Debug.Adapter.Watch as W+import Haskell.Debug.Adapter.TH.Utility+++--------------------------------------------------------------------------------+-- | Command Line Argument Data Type.+--+data ArgData = ArgData {+    _hackageVersionArgData :: String     -- ^hackage library version.+  } deriving (Data, Typeable, Show, Read, Eq)++makeLenses ''ArgData+$(deriveJSON+  defaultOptions {+      fieldLabelModifier = fieldModifier "ArgData"+    }+  ''ArgData)++-- |+--   default value instance.+--+instance Default ArgData where+  def = ArgData {+        _hackageVersionArgData = ""+      }+++-- |+--   start running HDA.+--+run :: ArgData   -- ^command line arguments type.+    -> Handle    -- ^IN handle. used to get request from debug adapter client.+    -> Handle    -- ^OUT handle. used to response to debug adapter client.+    -> IO Int    -- ^Exit code.+run _ inHdl outHdl = E.bracket initialize finalize go++  where+    -- |+    -- +    initialize = do+      L.debugM _LOG_NAME $ "initialize called."++      hSetBuffering inHdl NoBuffering+      hSetEncoding  inHdl utf8++      hSetBuffering outHdl NoBuffering+      hSetEncoding  outHdl utf8++      A.defaultAppStores inHdl outHdl++    -- |+    --+    finalize _ = do+      L.debugM _LOG_NAME $ "finalize called."+      L.removeAllHandlers++    -- |+    -- +    go appData = do++      L.debugM _LOG_NAME $ "start thread manager."++      let ths = [+                  RQ.run appData+                , A.run appData+                , RP.run appData+                , W.run appData+                ]++      TD.start appData ths >>= wait++      return 0+
+ src/Haskell/Debug/Adapter/GHCi.hs view
@@ -0,0 +1,237 @@+{-# 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 Control.Exception.Safe as E+import qualified Data.Map as M+import qualified Data.List as L+import qualified Data.String.Utils as U+--import qualified System.Log.Logger 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 cmd opts cwd envs = +  liftIO (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 = flip E.catches handlers $ 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+    handlers = [ E.Handler someExcept ]+    someExcept (e :: E.SomeException) = return . Left . show $ e++    -- |+    -- +    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 +++-- |+--+type ExpectCallBack = Bool -> [String] -> [String] -> AppContext ()++-- |+--   expect prompt or eof+-- +expectEOF :: ExpectCallBack -> AppContext [String]+expectEOF func = expectH' True func++-- |+--   expect prompt. eof throwError.+--+expectH :: ExpectCallBack -> AppContext [String]+expectH func = expectH' False func++-- |+--+expectH' :: Bool -> ExpectCallBack -> AppContext [String]+expectH' tilEOF func = do+  pmpt <- view ghciPmptAppStores <$> get+  mvar <- view ghciProcAppStores <$> get+  proc <- liftIO $ readMVar mvar+  let hdl = proc^.rHdlGHCiProc+      plen = length pmpt++  go tilEOF plen hdl []+  +  where+    go False plen hdl acc = U.readLine hdl >>= go' plen hdl acc+    go True plen hdl acc = liftIO (S.hIsEOF hdl) >>= \case+      False -> U.readLine hdl >>= go' plen hdl acc+      True  -> return acc++    go' plen hdl acc b = do+      let newL = U.rstrip b+      if L.isSuffixOf _DAP_CMD_END2 newL+        then goEnd plen hdl acc+        else cont plen hdl acc newL++    cont plen hdl acc newL = do+      let newAcc = acc ++ [newL]+      func False newAcc [newL]+      go tilEOF plen hdl newAcc++    goEnd plen hdl acc = do+      b <- liftIO $ B.hGet hdl plen+      let l = U.bs2str b+          newAcc = acc ++ [l]++      func True newAcc [l]+      return newAcc+++-- |+--+expect :: String -> ExpectCallBack -> AppContext ()+expect key func = do+  mvar <- view ghciProcAppStores <$> get+  proc <- liftIO $ readMVar mvar+  let hdl = proc^.rHdlGHCiProc++  xs <- go key hdl ""+  let strs = map U.rstrip $ lines xs++  func True strs strs++  where+    go kb hdl acc = U.readChar hdl+      >>= go' kb hdl acc++    go' kb hdl acc b = do+      let newAcc = acc ++ b+      if L.isSuffixOf kb newAcc+        then return newAcc+        else go kb hdl newAcc+++-- |+--  write to ghci.+--+command :: String -> AppContext ()+command cmd = do+  mver <- view ghciProcAppStores <$> get+  proc <- liftIO $ readMVar mver+  let hdl = proc^.wHdLGHCiProc++  liftIO (goIO hdl cmd) >>= liftEither++  where+    goIO hdl cmd = flip E.catchAny errHdl $ do+      Right <$> S.hPutStrLn hdl cmd++    errHdl e = return $ Left $ show e++-- |+--  write to ghci.+--+stdoutCallBk :: Bool -> [String] -> [String] -> AppContext ()+stdoutCallBk _ _ ([]) = return ()+stdoutCallBk True  _ (x:[]) = U.sendStdoutEvent x+stdoutCallBk False _ (x:[]) = U.sendStdoutEventLF x+stdoutCallBk True  _ xs = do+  mapM_ U.sendStdoutEventLF $ init xs+  U.sendStdoutEvent $ last xs+stdoutCallBk False _ xs = mapM_ U.sendStdoutEventLF xs+++-- |+--+cmdAndOut :: String -> AppContext ()+cmdAndOut cmd = do+  pout cmd+  command cmd+  where+    pout s+      | L.isPrefixOf ":dap-" s = U.sendStdoutEventLF $ (takeWhile ((/=) ' ') s) ++ " ..."+      | otherwise = U.sendStdoutEventLF s+      ++-- |+--  write to ghci.+--+funcCallBk :: (Bool -> String -> AppContext ()) -> Bool -> [String] -> [String] -> AppContext ()+funcCallBk _ _ _ ([]) = return ()+funcCallBk f b _ (x:[]) = f b x+funcCallBk f True  _ xs = do+  mapM_ (f False) $ init xs+  f True $ last xs+funcCallBk f False _ xs = mapM_ (f False) xs
+ src/Haskell/Debug/Adapter/Logger.hs view
@@ -0,0 +1,56 @@+module Haskell.Debug.Adapter.Logger where++import Haskell.Debug.Adapter.Constant++import System.IO+import qualified System.Log.Logger as L+import qualified System.Log.Formatter as L+import qualified System.Log.Handler as LH+import qualified System.Log.Handler.Simple as LHS+++-- |+--  setup logger+-- +setUpLogger :: FilePath -> L.Priority -> IO ()+setUpLogger path lv = do++  L.removeAllHandlers+  +  logStream <- openFile path AppendMode+  hSetEncoding logStream utf8+  hSetBuffering logStream NoBuffering++  logH <- LHS.streamHandler logStream lv++  let logHandle  = logH {LHS.closeFunc = hClose}+      logFormat  = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT+      logHandler = LH.setFormatter logHandle logFormat++  L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle])++  L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_NAME $ L.setLevel lv++  L.updateGlobalLogger _LOG_REQUEST $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_REQUEST $ L.setLevel lv++  L.updateGlobalLogger _LOG_RESPONSE $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_RESPONSE $ L.setLevel lv++  L.updateGlobalLogger _LOG_APP $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_APP $ L.setLevel lv++  L.updateGlobalLogger _LOG_THREAD_MGR $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_THREAD_MGR $ L.setLevel lv++  L.updateGlobalLogger _LOG_EVENT $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_EVENT $ L.setLevel lv++  L.updateGlobalLogger _LOG_GHCI_STDOUT $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_GHCI_STDOUT $ L.setLevel lv++  L.updateGlobalLogger _LOG_WATCH $ L.setHandlers [logHandler]+  L.updateGlobalLogger _LOG_WATCH $ L.setLevel lv++
+ src/Haskell/Debug/Adapter/Request.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE LambdaCase #-}++module Haskell.Debug.Adapter.Request where++import Control.Monad.IO.Class+import Data.Conduit+import Control.Lens+import Text.Parsec+import Data.Aeson+import qualified Data.ByteString.Lazy as B+import Control.Monad.State.Lazy+import qualified System.Log.Logger as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant++-- |+--+run :: AppStores -> IO ()+run appData = do+  L.debugM _LOG_REQUEST "start request app"+  _ <- runApp appData app+  L.debugM _LOG_REQUEST "end request app"+++-- |+--+app :: AppContext ()+app = flip catchError errHdl $ do+  _ <- runConduit pipeline+  return ()++  where+    pipeline :: ConduitM () Void AppContext ()+    pipeline = src .| lbs2req .| sink++    errHdl msg = do+      criticalEV _LOG_REQUEST msg+      addEvent CriticalExitEvent+++---------------------------------------------------------------------------------+-- |+--+src :: ConduitT () B.ByteString AppContext ()+src = do+  liftIO $ L.debugM _LOG_REQUEST $ "src start waiting."+  bs <- lift goApp+  yield bs+  src++  where+    goApp :: AppContext B.ByteString+    goApp = getContentLength >>= getContent+++-- |+--+getContent :: Int -> AppContext B.ByteString+getContent l = view inHandleAppStores <$> get+           >>= flip readCharsL l+++-- |+--+getContentLength :: AppContext Int+getContentLength = go B.empty+  where    +    go :: B.ByteString -> AppContext Int+    go buf = updateBuf buf >>= findLength++    updateBuf :: B.ByteString -> AppContext B.ByteString+    updateBuf buf = do+      hdl <- view inHandleAppStores <$> get+      B.append buf <$> readCharL hdl+    +    findLength :: B.ByteString -> AppContext Int+    findLength buf = case parse parser "find ContentLength parser" (lbs2str buf) of+      Left _  -> go buf+      Right l -> return l++    parser = do+      string _CONTENT_LENGTH+      len <- manyTill digit (string _TWO_CRLF)+      return . read $ len+++---------------------------------------------------------------------------------+-- |+--+lbs2req :: ConduitT B.ByteString WrapRequest AppContext ()+lbs2req = do+  liftIO $ L.debugM _LOG_REQUEST $ "lbs2req start waiting."+  await >>= \case+    Nothing  -> do+      throwError $ "unexpectHed Nothing."+    Just reqBS -> do+      liftIO $ L.debugM _LOG_REQUEST $ "lbs2req get data. " ++ lbs2str reqBS+      lift (goApp reqBS) >>= \case+        Nothing -> return ()+        Just rq -> yield rq+      lbs2req++  where+    goApp :: B.ByteString -> AppContext (Maybe WrapRequest)+    goApp reqBS = flip catchError errHdl $ do+      req <- decodeRequest reqBS+      reqW <- createWrapRequest reqBS req+      return $ Just reqW++    -- |+    --+    errHdl msg = do+      warnEV _LOG_REQUEST msg+      return Nothing++-- |+--+decodeRequest :: B.ByteString -> AppContext DAP.Request+decodeRequest bs = liftEither $ eitherDecode bs++-- |+--+createWrapRequest :: B.ByteString -> DAP.Request -> AppContext WrapRequest+createWrapRequest bs req +  | "initialize" == DAP.commandRequest req = WrapRequest . InitializeRequest <$> (liftEither (eitherDecode bs))+  | "launch"     == DAP.commandRequest req = WrapRequest . LaunchRequest <$> (liftEither (eitherDecode bs))+  | "disconnect" == DAP.commandRequest req = WrapRequest . DisconnectRequest <$> (liftEither (eitherDecode bs))+  | "pause" == DAP.commandRequest req = WrapRequest . PauseRequest <$> (liftEither (eitherDecode bs))+  | "terminate" == DAP.commandRequest req = WrapRequest . TerminateRequest <$> (liftEither (eitherDecode bs))+  | "setBreakpoints" == DAP.commandRequest req = WrapRequest . SetBreakpointsRequest <$> (liftEither (eitherDecode bs))+  | "setFunctionBreakpoints" == DAP.commandRequest req = WrapRequest . SetFunctionBreakpointsRequest <$> (liftEither (eitherDecode bs))+  | "setExceptionBreakpoints" == DAP.commandRequest req = WrapRequest . SetExceptionBreakpointsRequest <$> (liftEither (eitherDecode bs))+  | "configurationDone" == DAP.commandRequest req = WrapRequest . ConfigurationDoneRequest <$> (liftEither (eitherDecode bs))+  | "threads" == DAP.commandRequest req = WrapRequest . ThreadsRequest <$> (liftEither (eitherDecode bs))+  | "stackTrace" == DAP.commandRequest req = WrapRequest . StackTraceRequest <$> (liftEither (eitherDecode bs))+  | "scopes" == DAP.commandRequest req = WrapRequest . ScopesRequest <$> (liftEither (eitherDecode bs))+  | "variables" == DAP.commandRequest req = WrapRequest . VariablesRequest <$> (liftEither (eitherDecode bs))+  | "continue" == DAP.commandRequest req = WrapRequest . ContinueRequest <$> (liftEither (eitherDecode bs))+  | "next" == DAP.commandRequest req = WrapRequest . NextRequest <$> (liftEither (eitherDecode bs))+  | "stepIn" == DAP.commandRequest req = WrapRequest . StepInRequest <$> (liftEither (eitherDecode bs))+  | "evaluate" == DAP.commandRequest req = WrapRequest . EvaluateRequest <$> (liftEither (eitherDecode bs))+  | "completions" == DAP.commandRequest req = WrapRequest . CompletionsRequest <$> (liftEither (eitherDecode bs))+  | otherwise = throwError $ "unsupported request command. " ++ lbs2str bs+++---------------------------------------------------------------------------------+-- |+--+sink :: ConduitT WrapRequest Void AppContext ()+sink = do+  liftIO $ L.debugM _LOG_REQUEST $ "sink start waiting."+  await >>= \case+    Nothing  -> do+      throwError $ "unexpected Nothing."+      return ()+    Just req@(WrapRequest DisconnectRequest{}) -> do+      lift $ goApp req+      liftIO $ L.infoM _LOG_REQUEST $ "disconnect. end of request thread."+    Just req -> do+      lift $ goApp req+      sink++  where+    -- |+    --+    goApp :: WrapRequest -> AppContext ()+    goApp = addRequest++
+ src/Haskell/Debug/Adapter/Response.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE LambdaCase #-}++module Haskell.Debug.Adapter.Response where++import Control.Monad.IO.Class+import Data.Conduit+import Control.Lens+import Data.Aeson+import Control.Concurrent (threadDelay)+import qualified Data.ByteString.Lazy as B+import Control.Concurrent.MVar+import Control.Monad.State.Lazy+import qualified System.Log.Logger as L+import Control.Monad.Except+import qualified System.IO as S+import qualified Data.List as L++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant+++-- |+--+run :: AppStores -> IO ()+run appData = do+  L.debugM _LOG_RESPONSE "start response app"+  _ <- runApp appData app+  L.debugM _LOG_RESPONSE "end response app"+++-- |+--+app :: AppContext ()+app = flip catchError errHdl $ do+  _ <- runConduit pipeline+  return ()++  where+    pipeline :: ConduitM () Void AppContext ()+    pipeline = src .| res2lbs .| sink++    errHdl msg = do+      criticalEV _LOG_REQUEST msg+      addEvent CriticalExitEvent++---------------------------------------------------------------------------------+-- |+--+src :: ConduitT () Response AppContext ()+src = do+  liftIO $ L.debugM _LOG_RESPONSE $ "src start waiting."+  res <- lift goApp+  yield res+  src+++  where+    goApp :: AppContext Response+    goApp = get >>= liftIO . getResponse++-- |+--+getResponse :: AppStores -> IO Response+getResponse appDat = takeResponse appDat >>= \case+  Just res -> return res+  Nothing -> do+    threadDelay _1_MILLI_SEC+    getResponse appDat+++-- |+--+takeResponse :: AppStores -> IO (Maybe Response)+takeResponse appData = do+  let ressMVar = appData^.resStoreAppStores+  isExists ressMVar >>= \case+    False -> return Nothing+    True  -> take1 ressMVar++  where+    isExists ressMVar = readMVar ressMVar >>= \case+      [] -> return False+      _  -> return True++    take1 ressMVar = takeMVar ressMVar >>= \case+      [] -> do+        putMVar ressMVar []+        return Nothing+      (x:xs) -> do+        putMVar ressMVar xs+        return $ Just x+++---------------------------------------------------------------------------------+-- |+--+res2lbs :: ConduitT Response B.ByteString AppContext ()+res2lbs = do+  liftIO $ L.debugM _LOG_RESPONSE $ "res2lbs start waiting."+  await >>= \case+    Nothing -> do+      throwError $ "[CRITICAL][response][res2lbs] unexpectHed Nothing."+      return ()+    Just res -> do+      liftIO $ L.debugM _LOG_RESPONSE $ "res2lbs get data. " ++ show res+      bs <- lift $ goApp res+      yield bs+      res2lbs+  +  where+    goApp :: Response -> AppContext B.ByteString+    goApp = return . encode+++---------------------------------------------------------------------------------+-- |+--+sink :: ConduitT B.ByteString Void AppContext ()+sink = do+  liftIO $ L.debugM _LOG_RESPONSE $ "sink start start."+  await >>= \case+    Nothing  -> do+      throwError $ "[CRITICAL][response][sink] unexpectHed Nothing."+      return ()+    Just bs -> do+      liftIO $ L.debugM _LOG_RESPONSE $ "sink get data. " ++ lbs2str bs+      lift $ goApp bs+      cont $ lbs2str bs++  where+    goApp bs = do+      wHdl <- view outHandleAppStores <$> get+      liftIO $ sendResponse wHdl bs++    cont str+      | L.isInfixOf _KEY_DISCONNECT_RESPONCE str = do+        liftIO $ L.infoM _LOG_RESPONSE $ "disconnect. end of response thread."+      | otherwise = sink++-- |+--+_KEY_DISCONNECT_RESPONCE :: String+_KEY_DISCONNECT_RESPONCE = "\"command\":\"disconnect\""++-- |+--+sendResponse :: S.Handle -> B.ByteString -> IO ()+sendResponse hdl str = do+  B.hPut hdl $ str2lbs $ _CONTENT_LENGTH ++ (show (B.length str))+  B.hPut hdl $ str2lbs _TWO_CRLF+  B.hPut hdl str+  S.hFlush hdl+
+ src/Haskell/Debug/Adapter/State/Contaminated.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.Contaminated where++import Control.Monad.IO.Class+--import Control.Monad.Except+import qualified System.Log.Logger as L+import Control.Concurrent (threadDelay)++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import qualified Haskell.Debug.Adapter.Utility as U+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.State.Utility as SU+++-- | +--+instance AppStateIF ContaminatedState where+  -- |+  --+  entryAction ContaminatedState = do+    liftIO $ L.debugM _LOG_APP "ContaminatedState entryAction called."+    return ()++    +  -- |+  --+  exitAction ContaminatedState = do+    liftIO $ L.debugM _LOG_APP "ContaminatedState exitAction called."+    return ()+++  -- | +  --+  getStateRequest ContaminatedState (WrapRequest (InitializeRequest req))              = SU.unsupported $ show req+  getStateRequest ContaminatedState (WrapRequest (LaunchRequest req))                  = SU.unsupported $ show req+  getStateRequest ContaminatedState (WrapRequest (DisconnectRequest req))              = SU.unsupported $ show req+  getStateRequest ContaminatedState (WrapRequest (PauseRequest req))                   = SU.unsupported $ show req+  getStateRequest ContaminatedState (WrapRequest (TerminateRequest req))               = return . WrapStateRequest $ Contaminated_Terminate req+  +  getStateRequest ContaminatedState (WrapRequest (SetBreakpointsRequest req))          = return . WrapStateRequest $ Contaminated_SetBreakpoints req+  getStateRequest ContaminatedState (WrapRequest (SetFunctionBreakpointsRequest req))  = return . WrapStateRequest $ Contaminated_SetFunctionBreakpoints req+  getStateRequest ContaminatedState (WrapRequest (SetExceptionBreakpointsRequest req)) = return . WrapStateRequest $ Contaminated_SetExceptionBreakpoints req+  getStateRequest ContaminatedState (WrapRequest (ConfigurationDoneRequest req))       = SU.unsupported $ show req+  getStateRequest ContaminatedState (WrapRequest (ThreadsRequest req))                 = return . WrapStateRequest $ Contaminated_Threads req+  getStateRequest ContaminatedState (WrapRequest (StackTraceRequest req))              = return . WrapStateRequest $ Contaminated_StackTrace req+  getStateRequest ContaminatedState (WrapRequest (ScopesRequest req))                  = return . WrapStateRequest $ Contaminated_Scopes req+  getStateRequest ContaminatedState (WrapRequest (VariablesRequest req))               = return . WrapStateRequest $ Contaminated_Variables req+  getStateRequest ContaminatedState (WrapRequest (ContinueRequest req))                = return . WrapStateRequest $ Contaminated_Continue req+  getStateRequest ContaminatedState (WrapRequest (NextRequest req))                    = return . WrapStateRequest $ Contaminated_Next req+  getStateRequest ContaminatedState (WrapRequest (StepInRequest req))                  = return . WrapStateRequest $ Contaminated_StepIn req+  getStateRequest ContaminatedState (WrapRequest (EvaluateRequest req))                = return . WrapStateRequest $ Contaminated_Evaluate req+  getStateRequest ContaminatedState (WrapRequest (CompletionsRequest req))             = return . WrapStateRequest $ Contaminated_Completions req+  getStateRequest ContaminatedState (WrapRequest (InternalTransitRequest req))         = SU.unsupported $ show req+  getStateRequest ContaminatedState (WrapRequest (InternalTerminateRequest req))       = return . WrapStateRequest $ Contaminated_InternalTerminate req+  getStateRequest ContaminatedState (WrapRequest (InternalLoadRequest req))            = return . WrapStateRequest $ Contaminated_InternalLoad req+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.TerminateRequest where+  action (Contaminated_Terminate req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState TerminateRequest called. " ++ show req++    SU.terminateRequest req++    return $ Just Contaminated_Shutdown+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.SetBreakpointsRequest where+  action (Contaminated_SetBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState SetBreakpointsRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultSetBreakpointsResponse {+              DAP.seqSetBreakpointsResponse = resSeq+            , DAP.request_seqSetBreakpointsResponse = DAP.seqSetBreakpointsRequest req+            , DAP.successSetBreakpointsResponse = False+            , DAP.messageSetBreakpointsResponse = "Contaminated State. need restart."+            }++    U.addResponse $ SetBreakpointsResponse res+    return Nothing+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.SetFunctionBreakpointsRequest where+  action (Contaminated_SetFunctionBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState SetFunctionBreakpointsRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultSetFunctionBreakpointsResponse {+              DAP.seqSetFunctionBreakpointsResponse = resSeq+            , DAP.request_seqSetFunctionBreakpointsResponse = DAP.seqSetFunctionBreakpointsRequest req+            , DAP.successSetFunctionBreakpointsResponse = False+            , DAP.messageSetFunctionBreakpointsResponse = "Contaminated State. need restart."+            }++    U.addResponse $ SetFunctionBreakpointsResponse res+    return Nothing+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.SetExceptionBreakpointsRequest where+  action (Contaminated_SetExceptionBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState SetExceptionBreakpointsRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultSetExceptionBreakpointsResponse {+              DAP.seqSetExceptionBreakpointsResponse = resSeq+            , DAP.request_seqSetExceptionBreakpointsResponse = DAP.seqSetExceptionBreakpointsRequest req+            , DAP.successSetExceptionBreakpointsResponse = False+            , DAP.messageSetExceptionBreakpointsResponse = "Contaminated State. need restart."+            }++    U.addResponse $ SetExceptionBreakpointsResponse res+    return Nothing+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.ThreadsRequest where+  action (Contaminated_Threads req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState ThreadsRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultThreadsResponse {+              DAP.seqThreadsResponse = resSeq+            , DAP.request_seqThreadsResponse = DAP.seqThreadsRequest req+            , DAP.successThreadsResponse = True+            , DAP.messageThreadsResponse = "Contaminated State. need restart."+            }++    U.addResponse $ ThreadsResponse res+    return Nothing+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.StackTraceRequest where+  action (Contaminated_StackTrace req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState StackTraceRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultStackTraceResponse {+              DAP.seqStackTraceResponse = resSeq+            , DAP.request_seqStackTraceResponse = DAP.seqStackTraceRequest req+            , DAP.successStackTraceResponse = False+            , DAP.messageStackTraceResponse = "Contaminated State. need restart."+            }++    U.addResponse $ StackTraceResponse res+    return Nothing++++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.ScopesRequest where+  action (Contaminated_Scopes req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState ScopesRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultScopesResponse {+              DAP.seqScopesResponse = resSeq+            , DAP.request_seqScopesResponse = DAP.seqScopesRequest req+            , DAP.successScopesResponse = False+            , DAP.messageScopesResponse = "Contaminated State. need restart."+            }++    U.addResponse $ ScopesResponse res+    return Nothing++++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.VariablesRequest where+  action (Contaminated_Variables req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState VariablesRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultVariablesResponse {+              DAP.seqVariablesResponse = resSeq+            , DAP.request_seqVariablesResponse = DAP.seqVariablesRequest req+            , DAP.successVariablesResponse = False+            , DAP.messageVariablesResponse = "Contaminated State. need restart."+            }++    U.addResponse $ VariablesResponse res+    return Nothing+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.ContinueRequest where+  action (Contaminated_Continue req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState ContinueRequest called. " ++ show req+    restartEvent+    return $ Just Contaminated_Shutdown+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.NextRequest where+  action (Contaminated_Next req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState NextRequest called. " ++ show req+    restartEvent+    return $ Just Contaminated_Shutdown+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.StepInRequest where+  action (Contaminated_StepIn req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState StepInRequest called. " ++ show req+    restartEvent+    return $ Just Contaminated_Shutdown+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF ContaminatedState DAP.EvaluateRequest where+  action (Contaminated_Evaluate req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState EvaluateRequest called. " ++ show req+    SU.evaluateRequest req+++-- |+--+instance StateRequestIF ContaminatedState DAP.CompletionsRequest where+  action (Contaminated_Completions req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState CompletionsRequest called. " ++ show req+    SU.completionsRequest req++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF ContaminatedState HdaInternalTerminateRequest where+  action (Contaminated_InternalTerminate req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState InternalTerminateRequest called. " ++ show req+    SU.internalTerminateRequest+    return $ Just Contaminated_Shutdown+  ++-- |+--+instance StateRequestIF ContaminatedState HdaInternalLoadRequest where+  action (Contaminated_InternalLoad req) = do+    liftIO $ L.debugM _LOG_APP $ "ContaminatedState InternalLoadRequest called. " ++ show req+    SU.loadHsFile $ pathHdaInternalLoadRequest req+    return Nothing++-- |+--+restartEvent :: AppContext ()+restartEvent = do+  SU.terminateGHCi+  liftIO $ threadDelay _1_SEC++  U.sendConsoleEventLF ""+  U.sendConsoleEventLF "restarting debug adapter."+  U.sendConsoleEventLF ""++  U.sendRestartEvent+  U.sendExitedEvent+
+ src/Haskell/Debug/Adapter/State/DebugRun.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import Control.Monad.State.Lazy+import Control.Monad.Except+import Control.Lens+import qualified Text.Read as R+import qualified Data.List as L+import qualified Data.String.Utils as U++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import Haskell.Debug.Adapter.Type+import qualified Haskell.Debug.Adapter.GHCi as P+import Haskell.Debug.Adapter.State.DebugRun.Threads()+import Haskell.Debug.Adapter.State.DebugRun.StackTrace()+import Haskell.Debug.Adapter.State.DebugRun.Scopes()+import Haskell.Debug.Adapter.State.DebugRun.Variables()+import Haskell.Debug.Adapter.State.DebugRun.Continue()+import Haskell.Debug.Adapter.State.DebugRun.Next()+import Haskell.Debug.Adapter.State.DebugRun.StepIn()+import Haskell.Debug.Adapter.State.DebugRun.Terminate()+import Haskell.Debug.Adapter.State.DebugRun.InternalTerminate()+import qualified Haskell.Debug.Adapter.State.Utility as SU+++instance AppStateIF DebugRunState where+  -- |+  --+  entryAction DebugRunState = do+    liftIO $ L.debugM _LOG_APP "DebugRunState entryAction called."+    goEntry++  -- |+  --+  exitAction DebugRunState = do+    liftIO $ L.debugM _LOG_APP "DebugRunState exitAction called."+    return ()+++  -- | +  --+  getStateRequest DebugRunState (WrapRequest (InitializeRequest req))              = SU.unsupported $ show req+  getStateRequest DebugRunState (WrapRequest (LaunchRequest req))                  = SU.unsupported $ show req+  getStateRequest DebugRunState (WrapRequest (DisconnectRequest req))              = SU.unsupported $ show req+  getStateRequest DebugRunState (WrapRequest (PauseRequest req))                   = SU.unsupported $ show req+  +  getStateRequest DebugRunState (WrapRequest (TerminateRequest req))               = return . WrapStateRequest $ DebugRun_Terminate req+  getStateRequest DebugRunState (WrapRequest (SetBreakpointsRequest req))          = return . WrapStateRequest $ DebugRun_SetBreakpoints req+  getStateRequest DebugRunState (WrapRequest (SetFunctionBreakpointsRequest req))  = return . WrapStateRequest $ DebugRun_SetFunctionBreakpoints req+  getStateRequest DebugRunState (WrapRequest (SetExceptionBreakpointsRequest req)) = return . WrapStateRequest $ DebugRun_SetExceptionBreakpoints req++  getStateRequest DebugRunState (WrapRequest (ConfigurationDoneRequest req))       = SU.unsupported $ show req++  getStateRequest DebugRunState (WrapRequest (ThreadsRequest req))                 = return . WrapStateRequest $ DebugRun_Threads req+  getStateRequest DebugRunState (WrapRequest (StackTraceRequest req))              = return . WrapStateRequest $ DebugRun_StackTrace req+  getStateRequest DebugRunState (WrapRequest (ScopesRequest req))                  = return . WrapStateRequest $ DebugRun_Scopes req+  getStateRequest DebugRunState (WrapRequest (VariablesRequest req))               = return . WrapStateRequest $ DebugRun_Variables req+  getStateRequest DebugRunState (WrapRequest (ContinueRequest req))                = return . WrapStateRequest $ DebugRun_Continue req+  getStateRequest DebugRunState (WrapRequest (NextRequest req))                    = return . WrapStateRequest $ DebugRun_Next req+  getStateRequest DebugRunState (WrapRequest (StepInRequest req))                  = return . WrapStateRequest $ DebugRun_StepIn req+  getStateRequest DebugRunState (WrapRequest (EvaluateRequest req))                = return . WrapStateRequest $ DebugRun_Evaluate req+  getStateRequest DebugRunState (WrapRequest (CompletionsRequest req))             = return . WrapStateRequest $ DebugRun_Completions req++  getStateRequest DebugRunState (WrapRequest (InternalTransitRequest req))         = SU.unsupported $ show req+  getStateRequest DebugRunState (WrapRequest (InternalTerminateRequest req))       = return . WrapStateRequest $ DebugRun_InternalTerminate req+  getStateRequest DebugRunState (WrapRequest (InternalLoadRequest req))            = return . WrapStateRequest $ DebugRun_InternalLoad req++-- |+--+goEntry :: AppContext ()+goEntry = view stopOnEntryAppStores <$> get >>= \case+  True  -> stopOnEntry+  False -> startDebug++-- |+--+stopOnEntry :: AppContext ()+stopOnEntry = do+  startupFile <- view startupAppStores <$> get+  startupFunc <- view startupFuncAppStores <$> get++  let funcName = if null startupFunc then "main" else startupFunc+      funcBp   = (startupFile, DAP.FunctionBreakpoint funcName Nothing Nothing)+      cmd = ":dap-set-function-breakpoint " ++ U.showDAP funcBp++  P.cmdAndOut cmd+  res <- P.expectH P.stdoutCallBk+  +  withAdhocAddDapHeader $ filter (U.startswith _DAP_HEADER) res++  where+    -- |+    --+    withAdhocAddDapHeader :: [String] -> AppContext ()+    withAdhocAddDapHeader [] = do+      U.warnEV _LOG_APP $ "can not set func breakpoint. no dap header found."+      startDebug+    withAdhocAddDapHeader (str:[]) = case R.readEither (drop (length _DAP_HEADER) str) of+      Left err -> do+        U.warnEV _LOG_APP $ "read response body failed. " ++ err ++ " : " ++ str+        startDebug+      Right (Left err) -> do+        U.warnEV _LOG_APP $ "set adhoc breakpoint failed. " ++ err ++ " : " ++ str+        startDebug+      Right (Right bp) -> do+        startDebug+        adhocDelBreakpoint bp+    withAdhocAddDapHeader _ = do+      U.warnEV _LOG_APP $ "can not set func breakpoint. ambiguous dap header found."+      startDebug++    -- |+    --+    adhocDelBreakpoint :: DAP.Breakpoint -> AppContext ()+    adhocDelBreakpoint bp = do+      let cmd = ":dap-delete-breakpoint " ++ U.showDAP bp++      P.cmdAndOut cmd+      res <- P.expectH P.stdoutCallBk+      +      withAdhocDelDapHeader $ filter (U.startswith _DAP_HEADER) res++    -- |+    --+    withAdhocDelDapHeader :: [String] -> AppContext ()+    withAdhocDelDapHeader [] = throwError $ "can not del func breakpoint. no dap header found."+    withAdhocDelDapHeader (str:[]) = case R.readEither (drop (length _DAP_HEADER) str) of+      Left err -> throwError $ "read response body failed. " ++ err ++ " : " ++ str+      Right (Left err) -> throwError $ "del adhoc breakpoint failed. " ++ err ++ " : " ++ str+      Right (Right res) -> return res+    withAdhocDelDapHeader _ = throwError $ "can not del func breakpoint. ambiguous dap header found."+++-- |+--+startDebug :: AppContext ()+startDebug = do+  expr <- getTraceExpr+  let args = DAP.defaultContinueRequestArguments {+             DAP.exprContinueRequestArguments = Just expr+           }++  startDebugDAP args++  where+    getTraceExpr = view startupFuncAppStores <$> get >>= \case+      [] -> return "main"+      func -> do+        funcArgs <- view startupArgsAppStores <$> get+        return $ U.strip $ func ++ " " ++ funcArgs++    startDebugDAP args = do+        +      let dap = ":dap-continue "+          cmd = dap ++ U.showDAP args+          dbg = dap ++ show args++      P.cmdAndOut cmd+      U.debugEV _LOG_APP dbg+      P.expectH $ P.funcCallBk lineCallBk+      +      return ()++    +    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl str err+      Right (Left err) -> errHdl str err+      Right (Right body) -> U.handleStoppedEventBody body++    -- |+    --+    errHdl :: String -> String -> AppContext()+    errHdl str err = do+      let msg = "start debugging failed. " ++ err ++ " : " ++ str+      liftIO $ L.errorM _LOG_APP msg+      U.sendErrorEventLF msg+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF DebugRunState DAP.SetBreakpointsRequest where+  action (DebugRun_SetBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState SetBreakpointsRequest called. " ++ show req+    SU.setBreakpointsRequest req++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF DebugRunState DAP.SetExceptionBreakpointsRequest where+  action (DebugRun_SetExceptionBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState SetExceptionBreakpointsRequest called. " ++ show req+    SU.setExceptionBreakpointsRequest req++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF DebugRunState DAP.SetFunctionBreakpointsRequest where+  action (DebugRun_SetFunctionBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState SetFunctionBreakpointsRequest called. " ++ show req+    SU.setFunctionBreakpointsRequest req++-- |+--+instance StateRequestIF DebugRunState DAP.EvaluateRequest where+  action (DebugRun_Evaluate req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState EvaluateRequest called. " ++ show req+    SU.evaluateRequest req++-- |+--+instance StateRequestIF DebugRunState DAP.CompletionsRequest where+  action (DebugRun_Completions req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState CompletionsRequest called. " ++ show req+    SU.completionsRequest req+++-- |+--+instance StateRequestIF DebugRunState HdaInternalLoadRequest where+  action (DebugRun_InternalLoad req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState InternalLoadRequest called. " ++ show req+    SU.loadHsFile $ pathHdaInternalLoadRequest req+    return $ Just DebugRun_Contaminated+
+ src/Haskell/Debug/Adapter/State/DebugRun/Continue.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.Continue where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--+instance StateRequestIF DebugRunState DAP.ContinueRequest where+  action (DebugRun_Continue req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState ContinueRequest called. " ++ show req+    app req++-- |+--+app :: DAP.ContinueRequest -> AppContext (Maybe StateTransit)+app req = flip catchError errHdl $ do+  +  let args = DAP.argumentsContinueRequest req+      dap = ":dap-continue "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultContinueResponse {+            DAP.seqContinueResponse = resSeq+          , DAP.request_seqContinueResponse = DAP.seqContinueRequest req+          , DAP.successContinueResponse = True+          }++  U.addResponse $ ContinueResponse res++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> U.handleStoppedEventBody body+++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultContinueResponse {+                DAP.seqContinueResponse = resSeq+              , DAP.request_seqContinueResponse = DAP.seqContinueRequest req+              , DAP.successContinueResponse = False+              , DAP.messageContinueResponse = msg+              }++      U.addResponse $ ContinueResponse res+      return Nothing+
+ src/Haskell/Debug/Adapter/State/DebugRun/InternalTerminate.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.InternalTerminate where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import Control.Concurrent (threadDelay)++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.State.Utility as SU++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF DebugRunState HdaInternalTerminateRequest where+  action (DebugRun_InternalTerminate req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState InternalTerminateRequest called. " ++ show req+    app req+++-- |+--+app :: HdaInternalTerminateRequest -> AppContext (Maybe StateTransit)+app _ = do+  SU.terminateGHCi++  liftIO $ threadDelay _1_SEC++  U.sendTerminatedEvent+  U.sendExitedEvent++  return $ Just DebugRun_Shutdown+
+ src/Haskell/Debug/Adapter/State/DebugRun/Next.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.Next where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--+instance StateRequestIF DebugRunState DAP.NextRequest where+  action (DebugRun_Next req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState NextRequest called. " ++ show req+    app req++-- |+--+app :: DAP.NextRequest -> AppContext (Maybe StateTransit)+app req = flip catchError errHdl $ do+  +  let args = DAP.argumentsNextRequest req+      dap = ":dap-next "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultNextResponse {+            DAP.seqNextResponse = resSeq+          , DAP.request_seqNextResponse = DAP.seqNextRequest req+          , DAP.successNextResponse = True+          }++  U.addResponse $ NextResponse res++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> U.handleStoppedEventBody body+        ++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultNextResponse {+                DAP.seqNextResponse = resSeq+              , DAP.request_seqNextResponse = DAP.seqNextRequest req+              , DAP.successNextResponse = False+              , DAP.messageNextResponse = msg+              }++      U.addResponse $ NextResponse res+      return Nothing+
+ src/Haskell/Debug/Adapter/State/DebugRun/Scopes.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.Scopes where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--+instance StateRequestIF DebugRunState DAP.ScopesRequest where+  --action :: (StateRequest s r) -> AppContext ()+  action (DebugRun_Scopes req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState ScopesRequest called. " ++ show req+    app req++-- |+--+app :: DAP.ScopesRequest -> AppContext (Maybe StateTransit)+app req = flip catchError errHdl $ do+  +  let args = DAP.argumentsScopesRequest req+      dap = ":dap-scopes "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> do+        resSeq <- U.getIncreasedResponseSequence+        let res = DAP.defaultScopesResponse {+                  DAP.seqScopesResponse = resSeq+                , DAP.request_seqScopesResponse = DAP.seqScopesRequest req+                , DAP.successScopesResponse = True+                , DAP.bodyScopesResponse = body+                }++        U.addResponse $ ScopesResponse res++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultScopesResponse {+                DAP.seqScopesResponse = resSeq+              , DAP.request_seqScopesResponse = DAP.seqScopesRequest req+              , DAP.successScopesResponse = False+              , DAP.messageScopesResponse = msg+              }++      U.addResponse $ ScopesResponse res+      return Nothing+
+ src/Haskell/Debug/Adapter/State/DebugRun/StackTrace.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.StackTrace where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--+instance StateRequestIF DebugRunState DAP.StackTraceRequest where+  action (DebugRun_StackTrace req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState StackTraceRequest called. " ++ show req+    app req++-- |+--+app :: DAP.StackTraceRequest -> AppContext (Maybe StateTransit)+app req = flip catchError errHdl $ do+  +  let args = DAP.argumentsStackTraceRequest req+      dap = ":dap-stacktrace "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> do+        resSeq <- U.getIncreasedResponseSequence+        let res = DAP.defaultStackTraceResponse {+                  DAP.seqStackTraceResponse = resSeq+                , DAP.request_seqStackTraceResponse = DAP.seqStackTraceRequest req+                , DAP.successStackTraceResponse = True+                , DAP.bodyStackTraceResponse = body+                }++        U.addResponse $ StackTraceResponse res++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultStackTraceResponse {+                DAP.seqStackTraceResponse = resSeq+              , DAP.request_seqStackTraceResponse = DAP.seqStackTraceRequest req+              , DAP.successStackTraceResponse = False+              , DAP.messageStackTraceResponse = msg+              }++      U.addResponse $ StackTraceResponse res+      return Nothing+
+ src/Haskell/Debug/Adapter/State/DebugRun/StepIn.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.StepIn where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--+instance StateRequestIF DebugRunState DAP.StepInRequest where+  --action :: (StateRequest s r) -> AppContext ()+  action (DebugRun_StepIn req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState StepInRequest called. " ++ show req+    app req++-- |+--+app :: DAP.StepInRequest -> AppContext (Maybe StateTransit)+app req = flip catchError errHdl $ do+  +  let args = DAP.argumentsStepInRequest req+      dap = ":dap-step-in "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultStepInResponse {+            DAP.seqStepInResponse = resSeq+          , DAP.request_seqStepInResponse = DAP.seqStepInRequest req+          , DAP.successStepInResponse = True+          }++  U.addResponse $ StepInResponse res++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> U.handleStoppedEventBody body+++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultStepInResponse {+                DAP.seqStepInResponse = resSeq+              , DAP.request_seqStepInResponse = DAP.seqStepInRequest req+              , DAP.successStepInResponse = False+              , DAP.messageStepInResponse = msg+              }++      U.addResponse $ StepInResponse res+      return Nothing+
+ src/Haskell/Debug/Adapter/State/DebugRun/Terminate.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.Terminate where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import Control.Concurrent (threadDelay)++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.State.Utility as SU++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF DebugRunState DAP.TerminateRequest where+  action (DebugRun_Terminate req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState TerminateRequest called. " ++ show req+    app req+++-- |+--+app :: DAP.TerminateRequest -> AppContext (Maybe StateTransit)+app req = do+  SU.terminateGHCi++  liftIO $ threadDelay _1_SEC++  resSeq <- U.getIncreasedResponseSequence++  let res = DAP.defaultTerminateResponse {+            DAP.seqTerminateResponse         = resSeq+          , DAP.request_seqTerminateResponse = DAP.seqTerminateRequest req+          , DAP.successTerminateResponse     = True+          }++  U.addResponse $ TerminateResponse res+  U.sendTerminatedEvent+  U.sendExitedEvent++  return $ Just DebugRun_Shutdown+
+ src/Haskell/Debug/Adapter/State/DebugRun/Threads.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.Threads where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U++-- |+--+instance StateRequestIF DebugRunState DAP.ThreadsRequest where+  action (DebugRun_Threads req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState ThreadsRequest called. " ++ show req+    app req++-- |+--+app :: DAP.ThreadsRequest -> AppContext (Maybe StateTransit)+app req = do+  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultThreadsResponse {+            DAP.seqThreadsResponse = resSeq+          , DAP.request_seqThreadsResponse = DAP.seqThreadsRequest req+          , DAP.successThreadsResponse = True+          }++  U.addResponse $ ThreadsResponse res+  +  return Nothing
+ src/Haskell/Debug/Adapter/State/DebugRun/Variables.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.DebugRun.Variables where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--+instance StateRequestIF DebugRunState DAP.VariablesRequest where+  action (DebugRun_Variables req) = do+    liftIO $ L.debugM _LOG_APP $ "DebugRunState VariablesRequest called. " ++ show req+    app req++-- |+--+app :: DAP.VariablesRequest -> AppContext (Maybe StateTransit)+app req = flip catchError errHdl $ do+  +  let args = DAP.argumentsVariablesRequest req+      dap = ":dap-variables "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> do+        resSeq <- U.getIncreasedResponseSequence+        let res = DAP.defaultVariablesResponse {+                  DAP.seqVariablesResponse = resSeq+                , DAP.request_seqVariablesResponse = DAP.seqVariablesRequest req+                , DAP.successVariablesResponse = True+                , DAP.bodyVariablesResponse = body+                }++        U.addResponse $ VariablesResponse res++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultVariablesResponse {+                DAP.seqVariablesResponse = resSeq+              , DAP.request_seqVariablesResponse = DAP.seqVariablesRequest req+              , DAP.successVariablesResponse = False+              , DAP.messageVariablesResponse = msg+              }++      U.addResponse $ VariablesResponse res+      return Nothing+
+ src/Haskell/Debug/Adapter/State/GHCiRun.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.GHCiRun where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Constant+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.State.GHCiRun.ConfigurationDone()+import qualified Haskell.Debug.Adapter.State.Utility as SU+import qualified Haskell.Debug.Adapter.Utility as U++instance AppStateIF GHCiRunState where+  -- |+  --+  entryAction GHCiRunState = do+    liftIO $ L.debugM _LOG_APP "GHCiRunState entryAction called."+    return ()++  -- |+  --+  exitAction GHCiRunState = do+    liftIO $ L.debugM _LOG_APP "GHCiRunState exitAction called."+    return ()+++  -- | +  --+  getStateRequest GHCiRunState (WrapRequest (InitializeRequest req))              = SU.unsupported $ show req+  getStateRequest GHCiRunState (WrapRequest (LaunchRequest req))                  = SU.unsupported $ show req+  getStateRequest GHCiRunState (WrapRequest (DisconnectRequest req))              = SU.unsupported $ show req+  getStateRequest GHCiRunState (WrapRequest (PauseRequest req))                   = SU.unsupported $ show req+  +  getStateRequest GHCiRunState (WrapRequest (TerminateRequest req))               = return . WrapStateRequest $ GHCiRun_Terminate req+  getStateRequest GHCiRunState (WrapRequest (SetBreakpointsRequest req))          = return . WrapStateRequest $ GHCiRun_SetBreakpoints req+  getStateRequest GHCiRunState (WrapRequest (SetFunctionBreakpointsRequest req))  = return . WrapStateRequest $ GHCiRun_SetFunctionBreakpoints req+  getStateRequest GHCiRunState (WrapRequest (SetExceptionBreakpointsRequest req)) = return . WrapStateRequest $ GHCiRun_SetExceptionBreakpoints req+  getStateRequest GHCiRunState (WrapRequest (ConfigurationDoneRequest req))       = return . WrapStateRequest $ GHCiRun_ConfigurationDone req+  +  getStateRequest GHCiRunState (WrapRequest (ThreadsRequest req))                 = return . WrapStateRequest $ GHCiRun_Threads req+  getStateRequest GHCiRunState (WrapRequest (StackTraceRequest req))              = return . WrapStateRequest $ GHCiRun_StackTrace req+  getStateRequest GHCiRunState (WrapRequest (ScopesRequest req))                  = return . WrapStateRequest $ GHCiRun_Scopes req+  getStateRequest GHCiRunState (WrapRequest (VariablesRequest req))               = return . WrapStateRequest $ GHCiRun_Variables req++  getStateRequest GHCiRunState (WrapRequest (ContinueRequest req))                = return . WrapStateRequest $ GHCiRun_Continue req+  getStateRequest GHCiRunState (WrapRequest (NextRequest req))                    = return . WrapStateRequest $ GHCiRun_Next req+  getStateRequest GHCiRunState (WrapRequest (StepInRequest req))                  = return . WrapStateRequest $ GHCiRun_StepIn req++  getStateRequest GHCiRunState (WrapRequest (EvaluateRequest req))                = return . WrapStateRequest $ GHCiRun_Evaluate req+  getStateRequest GHCiRunState (WrapRequest (CompletionsRequest req))             = return . WrapStateRequest $ GHCiRun_Completions req++  getStateRequest GHCiRunState (WrapRequest (InternalTransitRequest req))         = SU.unsupported $ show req++  getStateRequest GHCiRunState (WrapRequest (InternalTerminateRequest req))       = return . WrapStateRequest $ GHCiRun_InternalTerminate req+  getStateRequest GHCiRunState (WrapRequest (InternalLoadRequest req))            = return . WrapStateRequest $ GHCiRun_InternalLoad req+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.SetBreakpointsRequest where+  action (GHCiRun_SetBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState SetBreakpointsRequest called. " ++ show req+    SU.setBreakpointsRequest req++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.SetExceptionBreakpointsRequest where+  action (GHCiRun_SetExceptionBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState SetExceptionBreakpointsRequest called. " ++ show req+    SU.setExceptionBreakpointsRequest req++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.SetFunctionBreakpointsRequest where+  action (GHCiRun_SetFunctionBreakpoints req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState SetFunctionBreakpointsRequest called. " ++ show req+    SU.setFunctionBreakpointsRequest req+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.TerminateRequest where+  action (GHCiRun_Terminate req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState TerminateRequest called. " ++ show req++    SU.terminateRequest req++    return $ Just GHCiRun_Shutdown+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.ThreadsRequest where+  action (GHCiRun_Threads req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState ThreadsRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultThreadsResponse {+              DAP.seqThreadsResponse = resSeq+            , DAP.request_seqThreadsResponse = DAP.seqThreadsRequest req+            , DAP.successThreadsResponse = False+            , DAP.messageThreadsResponse = "GHCiRun State. debugging not started."+            }++    U.addResponse $ ThreadsResponse res+    return Nothing++++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.StackTraceRequest where+  action (GHCiRun_StackTrace req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState StackTraceRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultStackTraceResponse {+              DAP.seqStackTraceResponse = resSeq+            , DAP.request_seqStackTraceResponse = DAP.seqStackTraceRequest req+            , DAP.successStackTraceResponse = False+            , DAP.messageStackTraceResponse = "GHCiRun State. debugging not started."+            }++    U.addResponse $ StackTraceResponse res+    return Nothing++++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.ScopesRequest where+  action (GHCiRun_Scopes req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState ScopesRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultScopesResponse {+              DAP.seqScopesResponse = resSeq+            , DAP.request_seqScopesResponse = DAP.seqScopesRequest req+            , DAP.successScopesResponse = False+            , DAP.messageScopesResponse = "GHCiRun State. debugging not started."+            }++    U.addResponse $ ScopesResponse res+    return Nothing++++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.VariablesRequest where+  action (GHCiRun_Variables req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState VariablesRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultVariablesResponse {+              DAP.seqVariablesResponse = resSeq+            , DAP.request_seqVariablesResponse = DAP.seqVariablesRequest req+            , DAP.successVariablesResponse = False+            , DAP.messageVariablesResponse = "GHCiRun State. debugging not started."+            }++    U.addResponse $ VariablesResponse res+    return Nothing++++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.ContinueRequest where+  action (GHCiRun_Continue req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState ContinueRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultContinueResponse {+              DAP.seqContinueResponse = resSeq+            , DAP.request_seqContinueResponse = DAP.seqContinueRequest req+            , DAP.successContinueResponse = True+            }++    U.addResponse $ ContinueResponse res++    return $ Just GHCiRun_DebugRun+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.NextRequest where+  action (GHCiRun_Next req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState NextRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultNextResponse {+              DAP.seqNextResponse = resSeq+            , DAP.request_seqNextResponse = DAP.seqNextRequest req+            , DAP.successNextResponse = True+            }++    U.addResponse $ NextResponse res++    return $ Just GHCiRun_DebugRun+++-- |+--  Any errors should be sent back as False result Response+--+instance StateRequestIF GHCiRunState DAP.StepInRequest where+  action (GHCiRun_StepIn req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState StepInRequest called. " ++ show req+    resSeq <- U.getIncreasedResponseSequence+    let res = DAP.defaultStepInResponse {+              DAP.seqStepInResponse = resSeq+            , DAP.request_seqStepInResponse = DAP.seqStepInRequest req+            , DAP.successStepInResponse = True+            }++    U.addResponse $ StepInResponse res++    return $ Just GHCiRun_DebugRun++++-- |+--+instance StateRequestIF GHCiRunState DAP.EvaluateRequest where+  action (GHCiRun_Evaluate req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState EvaluateRequest called. " ++ show req+    SU.evaluateRequest req++-- |+--+instance StateRequestIF GHCiRunState DAP.CompletionsRequest where+  action (GHCiRun_Completions req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState CompletionsRequest called. " ++ show req+    SU.completionsRequest req+++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF GHCiRunState HdaInternalTerminateRequest where+  action (GHCiRun_InternalTerminate req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState InternalTerminateRequest called. " ++ show req+    SU.internalTerminateRequest+    return $ Just GHCiRun_Shutdown+  ++-- |+--+instance StateRequestIF GHCiRunState HdaInternalLoadRequest where+  action (GHCiRun_InternalLoad req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState InternalLoadRequest called. " ++ show req+    SU.loadHsFile $ pathHdaInternalLoadRequest req+    return $ Just GHCiRun_Contaminated+
+ src/Haskell/Debug/Adapter/State/GHCiRun/ConfigurationDone.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.GHCiRun.ConfigurationDone where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import Control.Monad.State+import Control.Lens+++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF GHCiRunState DAP.ConfigurationDoneRequest where+  action (GHCiRun_ConfigurationDone req) = do+    liftIO $ L.debugM _LOG_APP $ "GHCiRunState ConfigurationDoneRequest called. " ++ show req+    app req++-- |+--   @see https://github.com/Microsoft/vscode/issues/4902+--   @see https://microsoft.github.io/debug-adapter-protocol/overview+--+app :: DAP.ConfigurationDoneRequest -> AppContext (Maybe StateTransit)+app req = do++  -- U.sendConsoleEvent _DEBUG_START_MSG+  -- U.sendStdoutEvent _GHCI_PROMPT_HDA++  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultConfigurationDoneResponse {+            DAP.seqConfigurationDoneResponse = resSeq+          , DAP.request_seqConfigurationDoneResponse = DAP.seqConfigurationDoneRequest req+          , DAP.successConfigurationDoneResponse = True+          }++  U.addResponse $ ConfigurationDoneResponse res+  +  -- launch response must be sent after configuration done response.+  reqSeq <- view launchReqSeqAppStores <$> get+  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultLaunchResponse {+            DAP.seqLaunchResponse         = resSeq+          , DAP.request_seqLaunchResponse = reqSeq+          , DAP.successLaunchResponse     = True+          }++  U.addResponse $ LaunchResponse res++  return $ Just GHCiRun_DebugRun++{-+-- |+--+--+_DEBUG_START_MSG :: String+_DEBUG_START_MSG = L.intercalate "\n" [+    ""+  , "  Now, ghci launched and configuration done."+  , "  Press F5 to start debugging."+  , "  Or modify source code. it will be loaded to ghci automatically."+  , " "+  ]+-}+
+ src/Haskell/Debug/Adapter/State/Init.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.Init where++import Control.Monad.IO.Class+import Control.Monad.Except+import qualified System.Log.Logger as L++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import Haskell.Debug.Adapter.State.Init.Initialize()+import Haskell.Debug.Adapter.State.Init.Launch()+import qualified Haskell.Debug.Adapter.State.Utility as SU+++-- | +--+instance AppStateIF InitState where+  -- |+  --+  entryAction InitState = do+    let msg = "InitState entryAction must not be called."+    throwError msg++  -- |+  --+  exitAction InitState = do+    liftIO $ L.debugM _LOG_APP "InitState exitAction called."+    return ()++  -- | +  --+  getStateRequest InitState (WrapRequest (InitializeRequest req))              = return . WrapStateRequest $ Init_Initialize req+  getStateRequest InitState (WrapRequest (LaunchRequest req))                  = return . WrapStateRequest $ Init_Launch req+  getStateRequest InitState (WrapRequest (DisconnectRequest req))              = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (PauseRequest req))                   = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (TerminateRequest req))               = SU.unsupported $ show req+  +  getStateRequest InitState (WrapRequest (SetBreakpointsRequest req))          = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (SetFunctionBreakpointsRequest req))  = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (SetExceptionBreakpointsRequest req)) = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (ConfigurationDoneRequest req))       = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (ThreadsRequest req))                 = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (StackTraceRequest req))              = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (ScopesRequest req))                  = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (VariablesRequest req))               = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (ContinueRequest req))                = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (NextRequest req))                    = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (StepInRequest req))                  = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (EvaluateRequest req))                = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (CompletionsRequest req))             = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (InternalTransitRequest req))         = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (InternalTerminateRequest req))       = SU.unsupported $ show req+  getStateRequest InitState (WrapRequest (InternalLoadRequest req))            = SU.unsupported $ show req+
+ src/Haskell/Debug/Adapter/State/Init/Initialize.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.Init.Initialize where++import Control.Monad.IO.Class+import qualified System.Log.Logger as L++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import Haskell.Debug.Adapter.Utility++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF InitState DAP.InitializeRequest where+  action (Init_Initialize req) = do+    liftIO $ L.debugM _LOG_APP $ "InitState InitializeRequest called. " ++ show req+    app req++-- |+--+app :: DAP.InitializeRequest -> AppContext (Maybe StateTransit)+app req = do+  debugEV _LOG_APP "initialize request called."++  resSeq <- U.getIncreasedResponseSequence+  let capa = DAP.defaultInitializeResponseBody {+             DAP.supportsConfigurationDoneRequestInitializeResponseBody  = True+           , DAP.supportsFunctionBreakpointsInitializeResponseBody       = True+           , DAP.supportsConditionalBreakpointsInitializeResponseBody    = True+           , DAP.supportsHitConditionalBreakpointsInitializeResponseBody = True+           , DAP.supportsEvaluateForHoversInitializeResponseBody         = True+           , DAP.exceptionBreakpointFiltersInitializeResponseBody        = [+                 DAP.ExceptionBreakpointsFilter "break-on-error" "break-on-error" False+               , DAP.ExceptionBreakpointsFilter "break-on-exception" "break-on-exception" False+               ]+           , DAP.supportsStepBackInitializeResponseBody                  = False+           , DAP.supportsSetVariableInitializeResponseBody               = False+           , DAP.supportsRestartFrameInitializeResponseBody              = False+           , DAP.supportsGotoTargetsRequestInitializeResponseBody        = False+           , DAP.supportsStepInTargetsRequestInitializeResponseBody      = False+           , DAP.supportsCompletionsRequestInitializeResponseBody        = True+           , DAP.supportsModulesRequestInitializeResponseBody            = False  -- no GUI on VSCode+           , DAP.additionalModuleColumnsInitializeResponseBody           = []     -- no GUI on VSCode+           , DAP.supportsLogPointsInitializeResponseBody                 = True+           , DAP.supportsTerminateRequestInitializeResponseBody          = True+           }+      res  = DAP.defaultInitializeResponse {+             DAP.seqInitializeResponse         = resSeq+           , DAP.request_seqInitializeResponse = DAP.seqInitializeRequest req+           , DAP.successInitializeResponse     = True+           , DAP.bodyInitializeResponse        = capa+           }++  U.addResponse $ InitializeResponse res+  return Nothing+++
+ src/Haskell/Debug/Adapter/State/Init/Launch.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.Init.Launch where++import Control.Monad.IO.Class+import Control.Monad.Except+import Control.Monad.State+import Control.Concurrent+import Control.Lens+import System.Directory+import System.FilePath+import Text.Parsec+import qualified Text.Read as R+import qualified System.Log.Logger as L+import qualified Data.String.Utils as U+import qualified Data.ByteString.Lazy as LB+import qualified Data.List as L+import qualified Data.Version as V++import qualified Haskell.DAP as DAP+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.State.Utility as SU+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Logger as L+import qualified Haskell.Debug.Adapter.GHCi as P++-- |+--   Any errors should be critical. don't catch anything here.+--+instance StateRequestIF InitState DAP.LaunchRequest where+  action (Init_Launch req) = do+    liftIO $ L.debugM _LOG_APP $ "InitState LaunchRequest called. " ++ show req+    app req+++-- |+--   @see https://github.com/Microsoft/vscode/issues/4902+--   @see https://microsoft.github.io/debug-adapter-protocol/overview+-- +app :: DAP.LaunchRequest -> AppContext (Maybe StateTransit)+app req = do+  +  setUpConfig req+  setUpLogger req+  createTasksJsonFile++  U.sendStdoutEvent "Configuration read.\n"+  U.sendConsoleEvent "Starting GHCi.\n"+  U.sendErrorEvent "Wait for a moment.\n\n"++  -- must start here. can not start in the entry of GHCiRun State.+  -- because there is a transition from DebugRun to GHCiRun.+  startGHCi req+  initGHCi++  -- dont send launch response here.+  -- it must send after configuration done response.+  modify $ \s-> s{_launchReqSeqAppStores = DAP.seqLaunchRequest req}++  -- after initialized event, vscode send setBreak... and+  -- ConfigurationDone request.+  initSeq <- U.getIncreasedResponseSequence+  U.addResponse $ InitializedEvent $ DAP.defaultInitializedEvent {DAP.seqInitializedEvent = initSeq}+  +  return $ Just Init_GHCiRun+++-- |+--+setUpConfig :: DAP.LaunchRequest -> AppContext ()+setUpConfig req = do+  let args = DAP.argumentsLaunchRequest req+  appStores <- get+  +  let wsMVar = appStores^.workspaceAppStores+      ws = DAP.workspaceLaunchRequestArguments args+  _ <- liftIO $ takeMVar wsMVar+  liftIO $ putMVar wsMVar ws+  liftIO $ L.debugM _LOG_APP $ "workspace is " ++ ws++  let logPRMVar = appStores^.logPriorityAppStores+  logPR <- getLogPriority $ DAP.logLevelLaunchRequestArguments args+  _ <- liftIO $ takeMVar logPRMVar+  liftIO $ putMVar logPRMVar logPR++  put appStores {+      _startupAppStores     = U.replace [_SEP_WIN] [_SEP_UNIX] (DAP.startupLaunchRequestArguments args)+    , _startupFuncAppStores = maybe "" (\s->if null (U.strip s) then "" else  (U.strip s)) (DAP.startupFuncLaunchRequestArguments args)+    , _startupArgsAppStores = maybe "" (id) (DAP.startupArgsLaunchRequestArguments args)+    , _stopOnEntryAppStores = DAP.stopOnEntryLaunchRequestArguments args+    , _mainArgsAppStores    = maybe "" (id) (DAP.mainArgsLaunchRequestArguments args)+    }++  where+    getLogPriority logPRStr = case R.readEither logPRStr of+      Right lv -> return lv+      Left err -> do+        U.sendErrorEvent $ "log priority is invalid. WARNING set. [" ++ err ++ "]\n"+        return L.WARNING++-- |+--+setUpLogger :: DAP.LaunchRequest -> AppContext ()+setUpLogger req = do+  let args = DAP.argumentsLaunchRequest req+  ctx <- get+  logPR <- liftIO $ readMVar $ ctx^.logPriorityAppStores++  liftIO $ L.setUpLogger (DAP.logFileLaunchRequestArguments args) logPR+++-- |+--+createTasksJsonFile :: AppContext ()+createTasksJsonFile = do+  ctx <- get+  wsPath <- liftIO $ readMVar $ ctx^.workspaceAppStores+  let jsonDir  = wsPath </> ".vscode"+      jsonFile = jsonDir </> "tasks.json"++  catchError+    (checkDir jsonDir >> checkFile jsonFile >> createFile jsonFile)+    errHdl++  where++    -- |+    --+    errHdl msg = liftIO $ L.debugM _LOG_APP msg++    -- |+    --+    checkDir jsonDir = liftIO (doesDirectoryExist jsonDir) >>= \case+      False -> throwError $ "setting folder not found. skip saveing tasks.json. DIR:" ++ jsonDir+      True -> return () ++    -- |+    --+    checkFile jsonFile = liftIO (doesFileExist jsonFile) >>= \case+      True -> throwError $ "tasks.json file exists. " ++ jsonFile+      False -> return () ++    -- |+    --+    createFile jsonFile = do+      liftIO $ U.saveFileBSL jsonFile _TASKS_JSON_FILE_CONTENTS+      U.sendConsoleEvent $ "create tasks.json file. " ++ jsonFile ++ "\n"+++-- |+--+startGHCi :: DAP.LaunchRequest -> AppContext ()+startGHCi req = do+  let args = DAP.argumentsLaunchRequest req+      initPmpt = maybe _GHCI_PROMPT id (DAP.ghciInitialPromptLaunchRequestArguments args)+      envs = DAP.ghciEnvLaunchRequestArguments args+      cmdStr = DAP.ghciCmdLaunchRequestArguments args+      cmdList = filter (not.null) $ U.split " " cmdStr+      cmd  = head cmdList+      opts = tail cmdList++  appStores <- get+  cwd <- liftIO $ readMVar $ appStores^.workspaceAppStores++  liftIO $ L.debugM _LOG_APP $ "ghci initial prompt [" ++ initPmpt ++ "]."++  U.sendStdoutEventLF $ "CWD:" ++ cwd+  U.sendStdoutEventLF $ "CMD:" ++ L.intercalate " " (cmd : opts)+  U.sendStdoutEventLF ""++  P.startGHCi cmd opts cwd envs+  P.expect initPmpt expCallBK++  where+    expCallBK _ _ ([]) = return ()+    expCallBK True  acc (x:[]) = do+      U.sendStdoutEvent x+      updateGHCiVersion acc+    expCallBK False _ (x:[]) = U.sendStdoutEventLF x+    expCallBK True  _ xs = do+      mapM_ U.sendStdoutEventLF $ init xs+      U.sendStdoutEvent $ last xs+    expCallBK False _ xs = mapM_ U.sendStdoutEventLF xs++    updateGHCiVersion acc = case parse verParser "getGHCiVersion" (unlines acc) of+      Right v -> updateGHCiVersion' v+      Left e  -> do+        U.sendConsoleEventLF $ "can not parse ghci version. [" ++ show e ++ "] assumes "  ++ V.showVersion _BASE_GHCI_VERSION ++ "."+        updateGHCiVersion' _BASE_GHCI_VERSION++    verParser = do+      _ <- manyTill anyChar (try (string "GHCi, version "))+      v1 <- manyTill digit (char '.')+      v2 <- manyTill digit (char '.')+      v3 <- manyTill digit (char ':')+      return $ V.makeVersion [read v1, read v2, read v3]++    updateGHCiVersion' v = do+      -- U.debugEV _LOG_APP $ "GHCi version is " ++ V.showVersion v+      mver <- view ghciVerAppStores <$> get+      liftIO $ putMVar mver v+++-- |+--+initGHCi :: AppContext ()+initGHCi = do+  setPrompt+  setMainArgs++  file <- view startupAppStores <$> get+  SU.loadHsFile file++-- |+--+setPrompt :: AppContext ()+setPrompt = do+  p <- view ghciPmptAppStores <$> get+  let pmpt = _DAP_CMD_END2 ++ "\\n" ++ p+      cmd  = ":set prompt \""++pmpt++"\""+      cmd2 = ":set prompt-cont \""++pmpt++"\""++  P.cmdAndOut cmd+  P.expectH P.stdoutCallBk++  P.cmdAndOut cmd2+  P.expectH P.stdoutCallBk++  return ()++-- |+--+setMainArgs :: AppContext ()+setMainArgs = view mainArgsAppStores <$> get >>= \case+  [] -> return ()+  args -> do+    let cmd  = ":set args "++args++    P.cmdAndOut cmd+    P.expectH P.stdoutCallBk++    return ()+++-- |+--+_TASKS_JSON_FILE_CONTENTS :: LB.ByteString+_TASKS_JSON_FILE_CONTENTS = U.str2lbs $ U.join "\n" $+  [+    "{"+  , "  // atuomatically created by phoityne-vscode"+  , "  "+  , "  \"version\": \"2.0.0\","+  , "  \"presentation\": {"+  , "    \"reveal\": \"always\","+  , "    \"panel\": \"new\""+  , "  },"+  , "  \"tasks\": ["+  , "    {"+  , "      \"group\": {"+  , "        \"kind\": \"build\","+  , "        \"isDefault\": true"+  , "      },"+  , "      \"label\": \"stack build\","+  , "      \"type\": \"shell\","+  , "      \"command\": \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \""+  , "    },"+  , "    { "+  , "      \"group\": \"build\","+  , "      \"type\": \"shell\","+  , "      \"label\": \"stack clean & build\","+  , "      \"command\": \"echo START_STACK_CLEAN_AND_BUILD && cd ${workspaceRoot} && stack clean && stack build && echo END_STACK_CLEAN_AND_BUILD \""+  , "    },"+  , "    { "+  , "      \"group\": {"+  , "        \"kind\": \"test\","+  , "        \"isDefault\": true"+  , "      },"+  , "      \"type\": \"shell\","+  , "      \"label\": \"stack test\","+  , "      \"command\": \"echo START_STACK_TEST && cd ${workspaceRoot} && stack test && echo END_STACK_TEST \""+  , "    },"+  , "    { "+  , "      \"isBackground\": true,"+  , "      \"type\": \"shell\","+  , "      \"label\": \"stack watch\","+  , "      \"command\": \"echo START_STACK_WATCH && cd ${workspaceRoot} && stack build --test --no-run-tests --file-watch && echo END_STACK_WATCH \""+  , "    }"+  , "  ]"+  , "}"+  ]+
+ src/Haskell/Debug/Adapter/State/Shutdown.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.Shutdown where++import Control.Monad.IO.Class+import Control.Monad.Except+import qualified System.Log.Logger as L++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant+++-- | +--+instance AppStateIF ShutdownState where+  -- |+  --+  entryAction ShutdownState = do+    liftIO $ L.debugM _LOG_APP "ShutdownState entryAction called."++    addEvent CriticalExitEvent++    return ()++    +  -- |+  --+  exitAction ShutdownState = do+    let msg = "ShutdownState exitAction must not be called."+    throwError msg+++  -- | +  --+  getStateRequest ShutdownState _ = do+    let msg = "ShutdownState does not support any request."+    throwError msg++
+ src/Haskell/Debug/Adapter/State/Utility.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Haskell.Debug.Adapter.State.Utility where++-- import Control.Monad.IO.Class+import qualified System.Log.Logger as L+import qualified Text.Read as R+import qualified Data.List as L+import Control.Monad.Except+import Control.Concurrent (threadDelay)++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Constant+import qualified Haskell.Debug.Adapter.Utility as U+import qualified Haskell.Debug.Adapter.GHCi as P+++-- | +--+unsupported :: String -> AppContext WrapStateRequest+unsupported reqStr = do+  let msg = "InitState does not support this request. " ++ reqStr+  throwError msg+++-- |+--+setBreakpointsRequest :: DAP.SetBreakpointsRequest -> AppContext (Maybe StateTransit)+setBreakpointsRequest req = flip catchError errHdl $ do+  let args = DAP.argumentsSetBreakpointsRequest req+      dap = ":dap-set-breakpoints "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> do+        resSeq <- U.getIncreasedResponseSequence+        let res = DAP.defaultSetBreakpointsResponse {+                  DAP.seqSetBreakpointsResponse = resSeq+                , DAP.request_seqSetBreakpointsResponse = DAP.seqSetBreakpointsRequest req+                , DAP.successSetBreakpointsResponse = True+                , DAP.bodySetBreakpointsResponse = body+                }++        U.addResponse $ SetBreakpointsResponse res++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      U.errorEV _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultSetBreakpointsResponse {+                DAP.seqSetBreakpointsResponse = resSeq+              , DAP.request_seqSetBreakpointsResponse = DAP.seqSetBreakpointsRequest req+              , DAP.successSetBreakpointsResponse = False+              , DAP.messageSetBreakpointsResponse = msg+              }++      U.addResponse $ SetBreakpointsResponse res+      return Nothing+++-- |+--+setExceptionBreakpointsRequest :: DAP.SetExceptionBreakpointsRequest -> AppContext (Maybe StateTransit)+setExceptionBreakpointsRequest req = do+  let args = DAP.argumentsSetExceptionBreakpointsRequest req+      filters = DAP.filtersSetExceptionBreakpointsRequestArguments args++  mapM_ go $ getOptions filters++  resSeq <- U.getIncreasedResponseSequence+  let res = DAP.defaultSetExceptionBreakpointsResponse {+            DAP.seqSetExceptionBreakpointsResponse = resSeq+          , DAP.request_seqSetExceptionBreakpointsResponse = DAP.seqSetExceptionBreakpointsRequest req+          , DAP.successSetExceptionBreakpointsResponse = True+          }++  U.addResponse $ SetExceptionBreakpointsResponse res++  return Nothing+  +  where+    getOptions filters+      | null filters                      = ["-fno-break-on-exception", "-fno-break-on-error"]+      | filters == ["break-on-error"]     = ["-fno-break-on-exception", "-fbreak-on-error"]+      | filters == ["break-on-exception"] = ["-fbreak-on-exception",    "-fno-break-on-error"]+      | otherwise                         = ["-fbreak-on-exception",    "-fbreak-on-error" ] ++    go opt = do+      let cmd = ":set " ++ opt++      P.cmdAndOut cmd+      P.expectH $ P.stdoutCallBk++++-- |+--+setFunctionBreakpointsRequest :: DAP.SetFunctionBreakpointsRequest -> AppContext (Maybe StateTransit)+setFunctionBreakpointsRequest req = flip catchError errHdl $ do+  let args = DAP.argumentsSetFunctionBreakpointsRequest req+      dap = ":dap-set-function-breakpoints "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl err >> return ()+      Right (Left err) -> errHdl err >> return ()+      Right (Right body) -> do+        resSeq <- U.getIncreasedResponseSequence+        let res = DAP.defaultSetFunctionBreakpointsResponse {+                  DAP.seqSetFunctionBreakpointsResponse = resSeq+                , DAP.request_seqSetFunctionBreakpointsResponse = DAP.seqSetFunctionBreakpointsRequest req+                , DAP.successSetFunctionBreakpointsResponse = True+                , DAP.bodySetFunctionBreakpointsResponse = body+                }++        U.addResponse $ SetFunctionBreakpointsResponse res++    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      U.errorEV _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultSetFunctionBreakpointsResponse {+                DAP.seqSetFunctionBreakpointsResponse = resSeq+              , DAP.request_seqSetFunctionBreakpointsResponse = DAP.seqSetFunctionBreakpointsRequest req+              , DAP.successSetFunctionBreakpointsResponse = False+              , DAP.messageSetFunctionBreakpointsResponse = msg+              }++      U.addResponse $ SetFunctionBreakpointsResponse res+      return Nothing++++-- |+--+terminateGHCi :: AppContext ()+terminateGHCi = do+  let cmd = ":quit"++  P.cmdAndOut cmd+  P.expectEOF $ P.stdoutCallBk+  return ()+++-- |+--+evaluateRequest :: DAP.EvaluateRequest -> AppContext (Maybe StateTransit)+evaluateRequest req = do++  let args = DAP.argumentsEvaluateRequest req+      dap = ":dap-evaluate "+      cmd = dap ++ U.showDAP args+      dbg = dap ++ show args++  P.cmdAndOut cmd+  U.debugEV _LOG_APP dbg+  P.expectH $ P.funcCallBk lineCallBk++  return Nothing+  +  where+    lineCallBk :: Bool -> String -> AppContext ()+    lineCallBk True  s = U.sendStdoutEvent s+    lineCallBk False s+      | L.isPrefixOf _DAP_HEADER s = do+        U.debugEV _LOG_APP s+        dapHdl $ drop (length _DAP_HEADER) s+      | otherwise = do+        liftIO $ L.errorM _LOG_APP s+        U.sendStdoutEventLF s++    -- |+    --+    dapHdl :: String -> AppContext ()+    dapHdl str = case R.readEither str of+      Left err -> errHdl $ err ++ " : " ++ str+      Right (Left err) -> errHdl err+      Right (Right body) -> do+        resSeq <- U.getIncreasedResponseSequence+        let res = DAP.defaultEvaluateResponse {+                  DAP.seqEvaluateResponse = resSeq+                , DAP.request_seqEvaluateResponse = DAP.seqEvaluateRequest req+                , DAP.successEvaluateResponse = True+                , DAP.bodyEvaluateResponse = body+                }++        U.addResponse $ EvaluateResponse res+++    -- |+    --+    errHdl :: String -> AppContext ()+    errHdl msg = do+      U.sendErrorEventLF msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultEvaluateResponse {+                DAP.seqEvaluateResponse = resSeq+              , DAP.request_seqEvaluateResponse = DAP.seqEvaluateRequest req+              , DAP.successEvaluateResponse = False+              , DAP.messageEvaluateResponse = msg+              }++      U.addResponse $ EvaluateResponse res++-- |+--+completionsRequest :: DAP.CompletionsRequest -> AppContext (Maybe StateTransit)+completionsRequest req = flip catchError errHdl $ do++  let args = DAP.argumentsCompletionsRequest req+      key  = DAP.textCompletionsRequestArguments args+      size = "0-50"+      cmd = ":complete repl " ++ size ++ " \"" ++ key ++ "\""++  P.cmdAndOut cmd+  outs <- P.expectH P.stdoutCallBk++  resSeq <- U.getIncreasedResponseSequence+  let items = createItems outs+      body  = DAP.defaultCompletionsResponseBody {+              DAP.targetsCompletionsResponseBody = items+            }+      res = DAP.defaultCompletionsResponse {+            DAP.seqCompletionsResponse = resSeq+          , DAP.request_seqCompletionsResponse = DAP.seqCompletionsRequest req+          , DAP.successCompletionsResponse = True+          , DAP.bodyCompletionsResponse = body+          }++  U.addResponse $ CompletionsResponse res++  return Nothing+  +  where+    -- |+    --+    errHdl :: String -> AppContext (Maybe StateTransit)+    errHdl msg = do+      liftIO $ L.errorM _LOG_APP msg+      resSeq <- U.getIncreasedResponseSequence+      let res = DAP.defaultCompletionsResponse {+                DAP.seqCompletionsResponse = resSeq+              , DAP.request_seqCompletionsResponse = DAP.seqCompletionsRequest req+              , DAP.successCompletionsResponse = False+              , DAP.messageCompletionsResponse = msg+              }++      U.addResponse $ CompletionsResponse res+      return Nothing++    -- |+    --+    createItems :: [String] -> [DAP.CompletionsItem]+    createItems = map (createItem . normalize) . extracCompleteList++    -- |+    --+    createItem :: String -> DAP.CompletionsItem+    createItem (':':xs) = DAP.CompletionsItem xs+    createItem xs = DAP.CompletionsItem xs++    -- |+    --+    normalize :: String -> String+    normalize xs+      | 2 < length xs = tail . init $ xs+      | otherwise = xs++    -- |+    --+    extracCompleteList :: [String] -> [String]+    extracCompleteList [] = []+    extracCompleteList (_:[]) = []+    extracCompleteList (_:_:[]) = []+    extracCompleteList xs = tail . init $ xs++++-- |+--+loadHsFile :: FilePath -> AppContext ()+loadHsFile file = do+  let cmd  = ":load "++ file++  P.cmdAndOut cmd+  P.expectH P.stdoutCallBk++  return ()+++-- |+--+terminateRequest :: DAP.TerminateRequest -> AppContext ()+terminateRequest req = do+  terminateGHCi++  liftIO $ threadDelay _1_SEC++  resSeq <- U.getIncreasedResponseSequence++  let res = DAP.defaultTerminateResponse {+            DAP.seqTerminateResponse         = resSeq+          , DAP.request_seqTerminateResponse = DAP.seqTerminateRequest req+          , DAP.successTerminateResponse     = True+          }++  U.addResponse $ TerminateResponse res+  U.sendTerminatedEvent+  U.sendExitedEvent++-- |+--+internalTerminateRequest :: AppContext ()+internalTerminateRequest = do++    terminateGHCi++    liftIO $ threadDelay _1_SEC++    U.sendTerminatedEvent+    U.sendExitedEvent++
+ src/Haskell/Debug/Adapter/TH/Utility.hs view
@@ -0,0 +1,13 @@++module Haskell.Debug.Adapter.TH.Utility where+++-- |+--+rdrop :: String -> String -> String+rdrop str = reverse . drop (length str) . reverse++-- |+--+fieldModifier :: String -> String -> String+fieldModifier str  = tail . rdrop str
+ src/Haskell/Debug/Adapter/Thread.hs view
@@ -0,0 +1,103 @@+module Haskell.Debug.Adapter.Thread where++import Control.Monad.IO.Class+import Control.Concurrent.Async+import Control.Concurrent+import qualified System.Log.Logger as L+import Data.Maybe+import qualified Data.List as L+import Control.Monad.State.Lazy+import Control.Lens+import Control.Monad.Except++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant+++-- |+--+start :: AppStores -> [IO ()] -> IO (Async ())+start dat acts = do+  as <- mapM async acts+  async $ run dat {_asyncsAppStores = as}++++-- |+--+run :: AppStores -> IO ()+run appData = do+  L.debugM _LOG_THREAD_MGR "satrt thread manager"+  runApp appData app+  L.debugM _LOG_THREAD_MGR "stop thread manager"+++-- |+--+app :: AppContext ()+app = catchError go errHdl+  where+    errHdl msg = do+      criticalEV _LOG_THREAD_MGR msg+      criticalEV _LOG_THREAD_MGR "stopping all threads."+      as <- view asyncsAppStores <$> get+      liftIO $ mapM_ cancel as+      +    go = isStop >>= \case+      True  -> return ()+      False -> do+        takeEvent >>= \case+          Nothing -> return ()+          Just ev -> runEvent ev+        liftIO $ threadDelay _1_SEC+        go+++-- |+--+isStop :: AppContext Bool+isStop = do+  as <- view asyncsAppStores <$> get+  res <- liftIO $ mapM poll as+  when (L.any isJust res) $+    liftIO $ L.debugM _LOG_THREAD_MGR $ "thread status." ++ show res++  return $ L.all isJust res+++-- |+--+takeEvent :: AppContext (Maybe Event)+takeEvent = do+  appDat <- get+  let mvar = appDat^.eventStoreAppStores+  liftIO $ goIO mvar+++  where+    goIO mvar = isExists mvar >>= \case+      False -> return Nothing+      True  -> take1 mvar++    isExists mvar = readMVar mvar >>= \case+      [] -> return False+      _  -> return True++    take1 mvar = takeMVar mvar >>= \case+      [] -> do+        putMVar mvar []+        return Nothing+      (x:xs) -> do+        putMVar mvar xs+        return $ Just x+++-- |+--+runEvent :: Event -> AppContext ()+runEvent CriticalExitEvent = do+  liftIO $ L.criticalM _LOG_THREAD_MGR "Critical exit started."+  as <- view asyncsAppStores <$> get+  liftIO $ mapM_ cancel as+
+ src/Haskell/Debug/Adapter/Type.hs view
@@ -0,0 +1,509 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Haskell.Debug.Adapter.Type where+++import Data.Default+import Control.Lens+import Data.Aeson+import Data.Aeson.TH+import Control.Monad.Except+import Control.Monad.State+import Control.Concurrent+import Control.Concurrent.Async+import qualified System.IO as S+import qualified Data.Text as T+import qualified System.Log.Logger as L+--import qualified Data.ByteString as B+import qualified System.Process as S+import qualified Data.Version as V++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.TH.Utility++--------------------------------------------------------------------------------+instance FromJSON  L.Priority  where+  parseJSON (String v) = pure $ read $ T.unpack v+  parseJSON o = error $ "json parse error. Priority:" ++ show o++instance ToJSON L.Priority  where+  toJSON (L.DEBUG)     = String $ T.pack "DEBUG"+  toJSON (L.INFO)      = String $ T.pack "INFO"+  toJSON (L.NOTICE)    = String $ T.pack "NOTICE"+  toJSON (L.WARNING)   = String $ T.pack "WARNING"+  toJSON (L.ERROR)     = String $ T.pack "ERROR"+  toJSON (L.CRITICAL)  = String $ T.pack "CRITICAL"+  toJSON (L.ALERT)     = String $ T.pack "ALERT"+  toJSON (L.EMERGENCY) = String $ T.pack "EMERGENCY"+  +--------------------------------------------------------------------------------+-- | Config Data+-- +data ConfigData = ConfigData {+    _workDirConfigData  :: FilePath+  , _logFileConfigData  :: FilePath+  , _logLevelConfigData :: L.Priority+  } deriving (Show, Read, Eq)++makeLenses ''ConfigData++instance Default ConfigData where+  def = ConfigData {+        _workDirConfigData  = "."+      , _logFileConfigData  = "haskell-debug-adapter.log" +      , _logLevelConfigData = L.WARNING+      }++$(deriveJSON defaultOptions { fieldLabelModifier = fieldModifier "ConfigData" } ''ConfigData)++++--------------------------------------------------------------------------------------++data StateTransit =+    Init_GHCiRun+  | Init_Shutdown+  | GHCiRun_DebugRun+  | GHCiRun_Contaminated+  | GHCiRun_Shutdown+  | DebugRun_Contaminated+  | DebugRun_Shutdown+  | DebugRun_GHCiRun+  | Contaminated_Shutdown+  deriving (Show, Read, Eq)++$(deriveJSON defaultOptions ''StateTransit)++--------------------------------------------------------------------------------------++data HdaInternalTransitRequest = HdaInternalTransitRequest {+    stateHdaInternalTransitRequest :: StateTransit+  } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions { fieldLabelModifier = fieldModifier "HdaInternalTransitRequest" } ''HdaInternalTransitRequest)+  +data HdaInternalTerminateRequest = HdaInternalTerminateRequest {+    msgHdaInternalTerminateRequest :: String+  } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions { fieldLabelModifier = fieldModifier "HdaInternalTerminateRequest" } ''HdaInternalTerminateRequest)++data HdaInternalLoadRequest = HdaInternalLoadRequest {+    pathHdaInternalLoadRequest :: FilePath+  } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions { fieldLabelModifier = fieldModifier "HdaInternalLoadRequest" } ''HdaInternalLoadRequest)++--------------------------------------------------------------------------------+-- | DAP Request Data+-- +++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Source"} ''DAP.Source)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SourceBreakpoint"} ''DAP.SourceBreakpoint)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Breakpoint"} ''DAP.Breakpoint)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "FunctionBreakpoint"} ''DAP.FunctionBreakpoint)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Thread"} ''DAP.Thread)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StackFrame"} ''DAP.StackFrame)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Scope"} ''DAP.Scope)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Variable"} ''DAP.Variable)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "VariablePresentationHint"} ''DAP.VariablePresentationHint)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "CompletionsItem"} ''DAP.CompletionsItem)+++-- jsonize+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Request"} ''DAP.Request)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "InitializeRequest"} ''DAP.InitializeRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "InitializeRequestArguments"} ''DAP.InitializeRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "LaunchRequest"} ''DAP.LaunchRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "LaunchRequestArguments"} ''DAP.LaunchRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "DisconnectRequest"} ''DAP.DisconnectRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "DisconnectRequestArguments"} ''DAP.DisconnectRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "PauseRequest"} ''DAP.PauseRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "PauseRequestArguments"} ''DAP.PauseRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "TerminateRequest"} ''DAP.TerminateRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "TerminateRequestArguments"} ''DAP.TerminateRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetBreakpointsRequest"} ''DAP.SetBreakpointsRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetBreakpointsRequestArguments"} ''DAP.SetBreakpointsRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetFunctionBreakpointsRequest"} ''DAP.SetFunctionBreakpointsRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetFunctionBreakpointsRequestArguments"} ''DAP.SetFunctionBreakpointsRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetExceptionBreakpointsRequest"} ''DAP.SetExceptionBreakpointsRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetExceptionBreakpointsRequestArguments"} ''DAP.SetExceptionBreakpointsRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ConfigurationDoneRequest"} ''DAP.ConfigurationDoneRequest)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ThreadsRequest"} ''DAP.ThreadsRequest)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StackTraceRequest"} ''DAP.StackTraceRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StackTraceRequestArguments"} ''DAP.StackTraceRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ScopesRequest"} ''DAP.ScopesRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ScopesRequestArguments"} ''DAP.ScopesRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "VariablesRequest"} ''DAP.VariablesRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "VariablesRequestArguments"} ''DAP.VariablesRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ContinueRequest"} ''DAP.ContinueRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ContinueRequestArguments"} ''DAP.ContinueRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "NextRequest"} ''DAP.NextRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "NextRequestArguments"} ''DAP.NextRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StepInRequest"} ''DAP.StepInRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StepInRequestArguments"} ''DAP.StepInRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "EvaluateRequest"} ''DAP.EvaluateRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "EvaluateRequestArguments"} ''DAP.EvaluateRequestArguments)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "CompletionsRequest"} ''DAP.CompletionsRequest)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "CompletionsRequestArguments"} ''DAP.CompletionsRequestArguments)+++-- request+data Request a where +  InitializeRequest :: DAP.InitializeRequest -> Request DAP.InitializeRequest+  LaunchRequest     :: DAP.LaunchRequest     -> Request DAP.LaunchRequest+  DisconnectRequest :: DAP.DisconnectRequest -> Request DAP.DisconnectRequest+  PauseRequest :: DAP.PauseRequest -> Request DAP.PauseRequest+  TerminateRequest :: DAP.TerminateRequest -> Request DAP.TerminateRequest+  SetBreakpointsRequest :: DAP.SetBreakpointsRequest -> Request DAP.SetBreakpointsRequest+  SetFunctionBreakpointsRequest :: DAP.SetFunctionBreakpointsRequest -> Request DAP.SetFunctionBreakpointsRequest+  SetExceptionBreakpointsRequest :: DAP.SetExceptionBreakpointsRequest -> Request DAP.SetExceptionBreakpointsRequest+  ConfigurationDoneRequest :: DAP.ConfigurationDoneRequest -> Request DAP.ConfigurationDoneRequest+  ThreadsRequest :: DAP.ThreadsRequest -> Request DAP.ThreadsRequest+  StackTraceRequest :: DAP.StackTraceRequest -> Request DAP.StackTraceRequest+  ScopesRequest :: DAP.ScopesRequest -> Request DAP.ScopesRequest+  VariablesRequest :: DAP.VariablesRequest -> Request DAP.VariablesRequest+  ContinueRequest :: DAP.ContinueRequest -> Request DAP.ContinueRequest+  NextRequest :: DAP.NextRequest -> Request DAP.NextRequest+  StepInRequest :: DAP.StepInRequest -> Request DAP.StepInRequest+  EvaluateRequest :: DAP.EvaluateRequest -> Request DAP.EvaluateRequest+  CompletionsRequest :: DAP.CompletionsRequest -> Request DAP.CompletionsRequest+  InternalTransitRequest :: HdaInternalTransitRequest -> Request HdaInternalTransitRequest+  InternalTerminateRequest :: HdaInternalTerminateRequest -> Request HdaInternalTerminateRequest+  InternalLoadRequest :: HdaInternalLoadRequest -> Request HdaInternalLoadRequest++data WrapRequest = forall a. WrapRequest (Request a)++--------------------------------------------------------------------------------+-- | DAP Response Data+-- ++-- jsonize+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "Response"} ''DAP.Response)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ColumnDescriptor"} ''DAP.ColumnDescriptor)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ExceptionBreakpointsFilter"} ''DAP.ExceptionBreakpointsFilter)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "InitializeResponse"} ''DAP.InitializeResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "InitializeResponseBody"} ''DAP.InitializeResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "LaunchResponse"} ''DAP.LaunchResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "OutputEvent"} ''DAP.OutputEvent)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "OutputEventBody"} ''DAP.OutputEventBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StoppedEvent"} ''DAP.StoppedEvent)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StoppedEventBody"} ''DAP.StoppedEventBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "InitializedEvent"} ''DAP.InitializedEvent)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "DisconnectResponse"} ''DAP.DisconnectResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "PauseResponse"} ''DAP.PauseResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "TerminateResponse"} ''DAP.TerminateResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetBreakpointsResponse"} ''DAP.SetBreakpointsResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetBreakpointsResponseBody"} ''DAP.SetBreakpointsResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetFunctionBreakpointsResponse"} ''DAP.SetFunctionBreakpointsResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetFunctionBreakpointsResponseBody"} ''DAP.SetFunctionBreakpointsResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "SetExceptionBreakpointsResponse"} ''DAP.SetExceptionBreakpointsResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ConfigurationDoneResponse"} ''DAP.ConfigurationDoneResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ThreadsResponse"} ''DAP.ThreadsResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ThreadsResponseBody"} ''DAP.ThreadsResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StackTraceResponse"} ''DAP.StackTraceResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StackTraceResponseBody"} ''DAP.StackTraceResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ScopesResponse"} ''DAP.ScopesResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ScopesResponseBody"} ''DAP.ScopesResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "VariablesResponse"} ''DAP.VariablesResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "VariablesResponseBody"} ''DAP.VariablesResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ContinueResponse"} ''DAP.ContinueResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "NextResponse"} ''DAP.NextResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "StepInResponse"} ''DAP.StepInResponse)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "EvaluateResponse"} ''DAP.EvaluateResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "EvaluateResponseBody"} ''DAP.EvaluateResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "CompletionsResponse"} ''DAP.CompletionsResponse)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "CompletionsResponseBody"} ''DAP.CompletionsResponseBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "TerminatedEvent"} ''DAP.TerminatedEvent)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "TerminatedEventBody"} ''DAP.TerminatedEventBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ExitedEvent"} ''DAP.ExitedEvent)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ExitedEventBody"} ''DAP.ExitedEventBody)++$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ContinuedEvent"} ''DAP.ContinuedEvent)+$(deriveJSON defaultOptions {fieldLabelModifier = rdrop "ContinuedEventBody"} ''DAP.ContinuedEventBody)+++-- response+data Response = +    InitializeResponse DAP.InitializeResponse+  | LaunchResponse     DAP.LaunchResponse+  | OutputEvent        DAP.OutputEvent+  | StoppedEvent       DAP.StoppedEvent+  | TerminatedEvent    DAP.TerminatedEvent+  | ExitedEvent        DAP.ExitedEvent+  | ContinuedEvent     DAP.ContinuedEvent+  | InitializedEvent   DAP.InitializedEvent+  | DisconnectResponse DAP.DisconnectResponse+  | PauseResponse DAP.PauseResponse+  | TerminateResponse DAP.TerminateResponse+  | SetBreakpointsResponse DAP.SetBreakpointsResponse+  | SetFunctionBreakpointsResponse DAP.SetFunctionBreakpointsResponse+  | SetExceptionBreakpointsResponse DAP.SetExceptionBreakpointsResponse+  | ConfigurationDoneResponse DAP.ConfigurationDoneResponse+  | ThreadsResponse DAP.ThreadsResponse+  | StackTraceResponse DAP.StackTraceResponse+  | ScopesResponse DAP.ScopesResponse+  | VariablesResponse DAP.VariablesResponse+  | ContinueResponse DAP.ContinueResponse+  | NextResponse DAP.NextResponse+  | StepInResponse DAP.StepInResponse+  | EvaluateResponse DAP.EvaluateResponse+  | CompletionsResponse DAP.CompletionsResponse+  deriving (Show, Read, Eq)++$(deriveJSON defaultOptions{sumEncoding = UntaggedValue} ''Response)++--------------------------------------------------------------------------------+-- | State+-- +data InitState+data GHCiRunState+data DebugRunState+data ContaminatedState+data ShutdownState++data AppState s where+  InitState     :: AppState InitState+  GHCiRunState  :: AppState GHCiRunState+  DebugRunState :: AppState DebugRunState+  ShutdownState :: AppState ShutdownState+  ContaminatedState :: AppState ContaminatedState++class AppStateIF s where+  entryAction :: (AppState s) -> AppContext ()+  exitAction  :: (AppState s) -> AppContext ()+  getStateRequest :: (AppState s) -> WrapRequest -> AppContext WrapStateRequest++data WrapAppState = forall s. (AppStateIF s) =>  WrapAppState (AppState s)++class WrapAppStateIF s where+  entryActionW :: s -> AppContext ()+  exitActionW  :: s -> AppContext ()+  getStateRequestW :: s -> WrapRequest -> AppContext WrapStateRequest++instance WrapAppStateIF WrapAppState where+  entryActionW (WrapAppState s) = entryAction s+  exitActionW  (WrapAppState s) = exitAction s+  getStateRequestW (WrapAppState s) r = getStateRequest s r+  ++--------------------------------------------------------------------------------------++data StateRequest s r where+  Init_Initialize :: DAP.InitializeRequest -> StateRequest InitState DAP.InitializeRequest+  Init_Launch     :: DAP.LaunchRequest     -> StateRequest InitState DAP.LaunchRequest+  Init_Terminate :: DAP.TerminateRequest -> StateRequest InitState DAP.TerminateRequest+  Init_SetBreakpoints :: DAP.SetBreakpointsRequest -> StateRequest InitState DAP.SetBreakpointsRequest+  Init_SetFunctionBreakpoints :: DAP.SetFunctionBreakpointsRequest -> StateRequest InitState DAP.SetFunctionBreakpointsRequest+  Init_SetExceptionBreakpoints :: DAP.SetExceptionBreakpointsRequest -> StateRequest InitState DAP.SetExceptionBreakpointsRequest+  Init_ConfigurationDone :: DAP.ConfigurationDoneRequest -> StateRequest InitState DAP.ConfigurationDoneRequest+  Init_Threads :: DAP.ThreadsRequest -> StateRequest InitState DAP.ThreadsRequest+  Init_StackTrace :: DAP.StackTraceRequest -> StateRequest InitState DAP.StackTraceRequest+  Init_Scopes :: DAP.ScopesRequest -> StateRequest InitState DAP.ScopesRequest+  Init_Variables :: DAP.VariablesRequest -> StateRequest InitState DAP.VariablesRequest+  Init_Continue :: DAP.ContinueRequest -> StateRequest InitState DAP.ContinueRequest+  Init_Next :: DAP.NextRequest -> StateRequest InitState DAP.NextRequest+  Init_StepIn :: DAP.StepInRequest -> StateRequest InitState DAP.StepInRequest+  Init_Evaluate :: DAP.EvaluateRequest -> StateRequest InitState DAP.EvaluateRequest+  Init_Completions :: DAP.CompletionsRequest -> StateRequest InitState DAP.CompletionsRequest+  Init_InternalTerminate :: HdaInternalTerminateRequest -> StateRequest InitState HdaInternalTerminateRequest+  Init_InternalLoad :: HdaInternalLoadRequest -> StateRequest InitState HdaInternalLoadRequest++  GHCiRun_Initialize :: DAP.InitializeRequest -> StateRequest GHCiRunState DAP.InitializeRequest+  GHCiRun_Launch     :: DAP.LaunchRequest     -> StateRequest GHCiRunState DAP.LaunchRequest+  GHCiRun_Terminate :: DAP.TerminateRequest -> StateRequest GHCiRunState DAP.TerminateRequest+  GHCiRun_SetBreakpoints :: DAP.SetBreakpointsRequest -> StateRequest GHCiRunState DAP.SetBreakpointsRequest+  GHCiRun_SetFunctionBreakpoints :: DAP.SetFunctionBreakpointsRequest -> StateRequest GHCiRunState DAP.SetFunctionBreakpointsRequest+  GHCiRun_SetExceptionBreakpoints :: DAP.SetExceptionBreakpointsRequest -> StateRequest GHCiRunState DAP.SetExceptionBreakpointsRequest+  GHCiRun_ConfigurationDone :: DAP.ConfigurationDoneRequest -> StateRequest GHCiRunState DAP.ConfigurationDoneRequest+  GHCiRun_Threads :: DAP.ThreadsRequest -> StateRequest GHCiRunState DAP.ThreadsRequest+  GHCiRun_StackTrace :: DAP.StackTraceRequest -> StateRequest GHCiRunState DAP.StackTraceRequest+  GHCiRun_Scopes :: DAP.ScopesRequest -> StateRequest GHCiRunState DAP.ScopesRequest+  GHCiRun_Variables :: DAP.VariablesRequest -> StateRequest GHCiRunState DAP.VariablesRequest+  GHCiRun_Continue :: DAP.ContinueRequest -> StateRequest GHCiRunState DAP.ContinueRequest+  GHCiRun_Next :: DAP.NextRequest -> StateRequest GHCiRunState DAP.NextRequest+  GHCiRun_StepIn :: DAP.StepInRequest -> StateRequest GHCiRunState DAP.StepInRequest+  GHCiRun_Evaluate :: DAP.EvaluateRequest -> StateRequest GHCiRunState DAP.EvaluateRequest+  GHCiRun_Completions :: DAP.CompletionsRequest -> StateRequest GHCiRunState DAP.CompletionsRequest+  GHCiRun_InternalTerminate :: HdaInternalTerminateRequest -> StateRequest GHCiRunState HdaInternalTerminateRequest+  GHCiRun_InternalLoad :: HdaInternalLoadRequest -> StateRequest GHCiRunState HdaInternalLoadRequest++  DebugRun_Initialize :: DAP.InitializeRequest -> StateRequest DebugRunState DAP.InitializeRequest+  DebugRun_Launch     :: DAP.LaunchRequest     -> StateRequest DebugRunState DAP.LaunchRequest+  DebugRun_Terminate :: DAP.TerminateRequest -> StateRequest DebugRunState DAP.TerminateRequest+  DebugRun_SetBreakpoints :: DAP.SetBreakpointsRequest -> StateRequest DebugRunState DAP.SetBreakpointsRequest+  DebugRun_SetFunctionBreakpoints :: DAP.SetFunctionBreakpointsRequest -> StateRequest DebugRunState DAP.SetFunctionBreakpointsRequest+  DebugRun_SetExceptionBreakpoints :: DAP.SetExceptionBreakpointsRequest -> StateRequest DebugRunState DAP.SetExceptionBreakpointsRequest+  DebugRun_ConfigurationDone :: DAP.ConfigurationDoneRequest -> StateRequest DebugRunState DAP.ConfigurationDoneRequest+  DebugRun_Threads :: DAP.ThreadsRequest -> StateRequest DebugRunState DAP.ThreadsRequest+  DebugRun_StackTrace :: DAP.StackTraceRequest -> StateRequest DebugRunState DAP.StackTraceRequest+  DebugRun_Scopes :: DAP.ScopesRequest -> StateRequest DebugRunState DAP.ScopesRequest+  DebugRun_Variables :: DAP.VariablesRequest -> StateRequest DebugRunState DAP.VariablesRequest+  DebugRun_Continue :: DAP.ContinueRequest -> StateRequest DebugRunState DAP.ContinueRequest+  DebugRun_Next :: DAP.NextRequest -> StateRequest DebugRunState DAP.NextRequest+  DebugRun_StepIn :: DAP.StepInRequest -> StateRequest DebugRunState DAP.StepInRequest+  DebugRun_Evaluate :: DAP.EvaluateRequest -> StateRequest DebugRunState DAP.EvaluateRequest+  DebugRun_Completions :: DAP.CompletionsRequest -> StateRequest DebugRunState DAP.CompletionsRequest+  DebugRun_InternalTerminate :: HdaInternalTerminateRequest -> StateRequest DebugRunState HdaInternalTerminateRequest+  DebugRun_InternalLoad :: HdaInternalLoadRequest -> StateRequest DebugRunState HdaInternalLoadRequest++  Shutdown_Initialize :: DAP.InitializeRequest -> StateRequest ShutdownState DAP.InitializeRequest+  Shutdown_Launch     :: DAP.LaunchRequest     -> StateRequest ShutdownState DAP.LaunchRequest+  Shutdown_Terminate :: DAP.TerminateRequest -> StateRequest ShutdownState DAP.TerminateRequest+  Shutdown_SetBreakpoints :: DAP.SetBreakpointsRequest -> StateRequest ShutdownState DAP.SetBreakpointsRequest+  Shutdown_SetFunctionBreakpoints :: DAP.SetFunctionBreakpointsRequest -> StateRequest ShutdownState DAP.SetFunctionBreakpointsRequest+  Shutdown_SetExceptionBreakpoints :: DAP.SetExceptionBreakpointsRequest -> StateRequest ShutdownState DAP.SetExceptionBreakpointsRequest+  Shutdown_ConfigurationDone :: DAP.ConfigurationDoneRequest -> StateRequest ShutdownState DAP.ConfigurationDoneRequest+  Shutdown_Threads :: DAP.ThreadsRequest -> StateRequest ShutdownState DAP.ThreadsRequest+  Shutdown_StackTrace :: DAP.StackTraceRequest -> StateRequest ShutdownState DAP.StackTraceRequest+  Shutdown_Scopes :: DAP.ScopesRequest -> StateRequest ShutdownState DAP.ScopesRequest+  Shutdown_Variables :: DAP.VariablesRequest -> StateRequest ShutdownState DAP.VariablesRequest+  Shutdown_Continue :: DAP.ContinueRequest -> StateRequest ShutdownState DAP.ContinueRequest+  Shutdown_Next :: DAP.NextRequest -> StateRequest ShutdownState DAP.NextRequest+  Shutdown_StepIn :: DAP.StepInRequest -> StateRequest ShutdownState DAP.StepInRequest+  Shutdown_Evaluate :: DAP.EvaluateRequest -> StateRequest ShutdownState DAP.EvaluateRequest+  Shutdown_Completions :: DAP.CompletionsRequest -> StateRequest ShutdownState DAP.CompletionsRequest+  Shutdown_InternalTerminate :: HdaInternalTerminateRequest -> StateRequest ShutdownState HdaInternalTerminateRequest+  Shutdown_InternalLoad :: HdaInternalLoadRequest -> StateRequest ShutdownState HdaInternalLoadRequest++  Contaminated_Initialize :: DAP.InitializeRequest -> StateRequest ContaminatedState DAP.InitializeRequest+  Contaminated_Launch     :: DAP.LaunchRequest     -> StateRequest ContaminatedState DAP.LaunchRequest+  Contaminated_Terminate :: DAP.TerminateRequest -> StateRequest ContaminatedState DAP.TerminateRequest+  Contaminated_SetBreakpoints :: DAP.SetBreakpointsRequest -> StateRequest ContaminatedState DAP.SetBreakpointsRequest+  Contaminated_SetFunctionBreakpoints :: DAP.SetFunctionBreakpointsRequest -> StateRequest ContaminatedState DAP.SetFunctionBreakpointsRequest+  Contaminated_SetExceptionBreakpoints :: DAP.SetExceptionBreakpointsRequest -> StateRequest ContaminatedState DAP.SetExceptionBreakpointsRequest+  Contaminated_ConfigurationDone :: DAP.ConfigurationDoneRequest -> StateRequest ContaminatedState DAP.ConfigurationDoneRequest+  Contaminated_Threads :: DAP.ThreadsRequest -> StateRequest ContaminatedState DAP.ThreadsRequest+  Contaminated_StackTrace :: DAP.StackTraceRequest -> StateRequest ContaminatedState DAP.StackTraceRequest+  Contaminated_Scopes :: DAP.ScopesRequest -> StateRequest ContaminatedState DAP.ScopesRequest+  Contaminated_Variables :: DAP.VariablesRequest -> StateRequest ContaminatedState DAP.VariablesRequest+  Contaminated_Continue :: DAP.ContinueRequest -> StateRequest ContaminatedState DAP.ContinueRequest+  Contaminated_Next :: DAP.NextRequest -> StateRequest ContaminatedState DAP.NextRequest+  Contaminated_StepIn :: DAP.StepInRequest -> StateRequest ContaminatedState DAP.StepInRequest+  Contaminated_Evaluate :: DAP.EvaluateRequest -> StateRequest ContaminatedState DAP.EvaluateRequest+  Contaminated_Completions :: DAP.CompletionsRequest -> StateRequest ContaminatedState DAP.CompletionsRequest+  Contaminated_InternalTerminate :: HdaInternalTerminateRequest -> StateRequest ContaminatedState HdaInternalTerminateRequest+  Contaminated_InternalLoad :: HdaInternalLoadRequest -> StateRequest ContaminatedState HdaInternalLoadRequest++class StateRequestIF s r where+  action :: (StateRequest s r) -> AppContext (Maybe StateTransit)++data WrapStateRequest = forall s r. (StateRequestIF s r) => WrapStateRequest (StateRequest s r)++class WrapStateRequestIF w where+  actionW :: w -> AppContext  (Maybe StateTransit)++instance WrapStateRequestIF WrapStateRequest where+  actionW (WrapStateRequest x) = action x++++--------------------------------------------------------------------------------+-- | Event+-- +data Event =+  CriticalExitEvent+  deriving (Show, Read, Eq)+++--------------------------------------------------------------------------------+-- | +-- +data GHCiProc = GHCiProc {+    _wHdLGHCiProc :: S.Handle+  , _rHdlGHCiProc :: S.Handle+  , _errGHCiProc  :: S.Handle+  , _procGHCiProc :: S.ProcessHandle+  }+++--------------------------------------------------------------------------------+-- | Application Context+-- +                      +type ErrMsg = String+type AppContext = StateT AppStores (ExceptT ErrMsg IO) +++-- | Application Context Data+-- +data AppStores = AppStores {+  -- Read Only+    _appNameAppStores     :: String+  , _appVerAppStores      :: String+  , _inHandleAppStores    :: S.Handle+  , _outHandleAppStores   :: S.Handle+  , _asyncsAppStores      :: [Async ()]++  -- Read/Write from Application+  , _appStateWAppStores   :: WrapAppState+  , _resSeqAppStores      :: Int+  , _startupAppStores     :: FilePath+  , _startupFuncAppStores :: String+  , _startupArgsAppStores :: String+  , _stopOnEntryAppStores :: Bool+  , _ghciPmptAppStores    :: String+  , _mainArgsAppStores    :: String+  , _launchReqSeqAppStores :: Int+  , _debugReRunableAppStores :: Bool++  -- Global Read/Write ASync+  , _reqStoreAppStores    :: MVar [WrapRequest]+  , _resStoreAppStores    :: MVar [Response]+  , _eventStoreAppStores  :: MVar [Event]+  , _workspaceAppStores   :: MVar FilePath+  , _logPriorityAppStores :: MVar L.Priority+  , _ghciProcAppStores    :: MVar GHCiProc+  --, _ghciStdoutAppStores  :: MVar B.ByteString+  , _ghciVerAppStores     :: MVar V.Version+  } ++makeLenses ''AppStores+makeLenses ''GHCiProc++
+ src/Haskell/Debug/Adapter/Utility.hs view
@@ -0,0 +1,523 @@+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+++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'+++-- |+--+sendDisconnectResponse :: DAP.DisconnectRequest -> AppContext ()+sendDisconnectResponse req = do+  resSeq <- getIncreasedResponseSequence++  let res = DAP.defaultDisconnectResponse {+            DAP.seqDisconnectResponse         = resSeq+          , DAP.request_seqDisconnectResponse = DAP.seqDisconnectRequest req+          , DAP.successDisconnectResponse     = True+          }++  addResponse $ DisconnectResponse res+++-- |+--+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 = liftIO (goIO hdl) >>= liftEither+    +    goIO hdl = flip E.catchAny errHdl $ do+      Right <$> S.hGetLine hdl++    errHdl = return . Left . show++-- |+--+readChar :: S.Handle -> AppContext String+readChar hdl = isOpenHdl hdl+           >>= isReadableHdl+           >>= isNotEofHdl+           >>= go+           >>= toString+           >>= isNotEmpty++  where+    go hdl = liftIO (goIO hdl) >>= liftEither+    +    goIO hdl = flip E.catchAny errHdl $ do+      Right <$> S.hGetChar hdl++    errHdl = return . Left . show++    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 = liftIO (goIO hdl) >>= liftEither++    goIO hdl = flip E.catchAny errHdl $ do+      Right <$> BSL.hGet hdl c++    errHdl = return . Left . show+++-- |+--+isOpenHdl :: S.Handle -> AppContext S.Handle+isOpenHdl rHdl = liftIO (S.hIsOpen rHdl) >>= \case+  True  -> return rHdl+  False -> throwError "invalid HANDLE. not opened."+++-- |+--+isReadableHdl :: S.Handle -> AppContext S.Handle+isReadableHdl rHdl = liftIO (S.hIsReadable rHdl) >>= \case+  True  -> return rHdl+  False -> throwError "invalid HANDLE. not readable."+++-- |+--+isNotEofHdl :: S.Handle -> AppContext S.Handle+isNotEofHdl rHdl = liftIO (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])+++
+ src/Haskell/Debug/Adapter/Watch.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE LambdaCase #-}++module Haskell.Debug.Adapter.Watch where++import Control.Monad.IO.Class+import qualified System.FSNotify as S+import Control.Lens+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar+import Control.Monad.State.Lazy+import qualified System.Log.Logger as L+import Control.Monad.Except+import qualified Data.List as L++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant+++-- |+--+run :: AppStores -> IO ()+run appData = do+  L.debugM _LOG_WATCH "start watch app"+  _ <- runApp appData app+  L.debugM _LOG_WATCH "end watch app"+++-- |+--+app :: AppContext ()+app = flip catchError errHdl $ do+  liftIO $ L.infoM _LOG_WATCH "wait getting workspace path."+  ws <- getWS+  liftIO $ L.infoM _LOG_WATCH $ "start watching " ++ ws++  reqStore <- view reqStoreAppStores <$> get+  let conf = S.defaultConfig { S.confDebounce  = S.Debounce 1} +  liftIO $ S.withManagerConf conf $ goIO ws reqStore+  +  where+    -- |+    --+    errHdl msg = do+      criticalEV _LOG_REQUEST msg+      addEvent CriticalExitEvent++    -- |+    --+    goIO ws reqStore mgr = do+      S.watchTree mgr ws hsFilter (action reqStore)+      forever $ threadDelay _1_SEC++    -- |+    --+    hsFilter ev = L.isSuffixOf _HS_FILE_EXT $ S.eventPath ev++    -- |+    --+    action mvar ev@(S.Added{}) = sendRequest mvar ev+    action mvar ev@(S.Modified{}) = sendRequest mvar ev+    action _ _ = return ()++    -- |+    --+    sendRequest mvar ev = do+      L.debugM _LOG_WATCH $ "detect. " ++ show ev+      let req = WrapRequest $ InternalLoadRequest +              $ HdaInternalLoadRequest $ S.eventPath ev+      reqs <- takeMVar mvar+      putMVar mvar (req : reqs)+  ++    -- |+    -- +    getWS :: AppContext FilePath+    getWS = do+      wsMVar <- view workspaceAppStores <$> get+      ws <- liftIO $ readMVar wsMVar+      if not (null ws) then return ws+        else do+          liftIO $ threadDelay _1_SEC+          getWS+
+ test/Haskell/Debug/Adapter/ControlSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Haskell.Debug.Adapter.ControlSpec where++import Test.Hspec+import Data.Aeson+import Data.Default+import Control.Concurrent (threadDelay)+import qualified System.IO as S+import Control.Concurrent.Async++import Spec.Utility++import qualified Haskell.DAP as DAP+import Haskell.Debug.Adapter.Control++-- |+--+spec :: Spec+spec = do+  runIO $ putStrLn "Start Haskell.Debug.Adapter.ControlSpec"+  beforeAll_ beforeAll'+    . afterAll_ afterAll'+    . before_ before'+    . after_  after'+    $ spec'++  where+  +    beforeAll' :: IO ()+    beforeAll' = do+      return ()++    afterAll' ::IO ()+    afterAll' = do+      return ()++    before' :: IO ()+    before' = return ()++    after' :: IO ()+    after' = return ()+    ++    spec' :: Spec+    spec' = do+      describe "run" $ do+        context "when default args" $ +          xit "should be 0" $ do+            let arg  = def+            (fromClient, toClient) <- createPipe+            (fromServer, toServer) <- createPipe++            (res, _) <- runConcurrently $ (,)+              <$> Concurrently (run arg fromClient toClient)+              <*> Concurrently (client toServer)++            res `shouldBe` 0++            S.hClose fromClient+            S.hClose toClient+            S.hClose fromServer+            S.hClose toServer++    client wHdl = do+      let req = DAP.defaultInitializeRequest+          jsonBS = encode req++      request wHdl jsonBS++      threadDelay _1_SEC++      return ()
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Spec/Utility.hs view
@@ -0,0 +1,96 @@++module Spec.Utility where++--import Control.Lens+import qualified System.IO as S+import qualified System.Process as S+import qualified Data.ByteString.Lazy as B+import Control.Concurrent.MVar+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE++--import qualified System.Log.Logger as L+--import qualified System.Log.Formatter as L+--import qualified System.Log.Handler as LH+--import qualified System.Log.Handler.Simple as LHS+++-- |+-- +_CONTENT_LENGTH :: String+_CONTENT_LENGTH = "Content-Length: " +++-- |+--+_TWO_CRLF :: String+_TWO_CRLF = "\r\n\r\n"+++-- |+--+_1_MILLI_SEC :: Int+_1_MILLI_SEC = 1 * 1000++-- |+--+_10_MILLI_SEC :: Int+_10_MILLI_SEC = 10 * 1000+++-- |+--+_100_MILLI_SEC :: Int+_100_MILLI_SEC = 100 * 1000+++-- |+--+_1_SEC :: Int+_1_SEC = 1000 * 1000+++-- |+--+str2lbs :: String -> B.ByteString+str2lbs = TLE.encodeUtf8 . TL.pack++-- |+--+lbs2str :: B.ByteString -> String+lbs2str = TL.unpack. TLE.decodeUtf8++-- |+--+createPipe :: IO (S.Handle, S.Handle)+createPipe = do+  (rHdl, wHdl) <- S.createPipe++  S.hSetBuffering rHdl S.NoBuffering+  S.hSetEncoding rHdl S.utf8+  S.hSetNewlineMode rHdl $ S.NewlineMode S.CRLF S.LF++  S.hSetBuffering wHdl S.NoBuffering+  S.hSetEncoding wHdl S.utf8+  S.hSetNewlineMode wHdl $ S.NewlineMode S.CRLF S.LF++  return (rHdl, wHdl) +++-- |+--+read2buf :: S.Handle -> MVar B.ByteString -> IO ()+read2buf hdl bufMVar = do+  s <- B.hGet hdl 1+  buf <- takeMVar bufMVar+  putMVar bufMVar $ buf `B.append` s+  read2buf hdl bufMVar++-- |+--+request :: S.Handle -> B.ByteString -> IO ()+request hdl str = do+  B.hPut hdl $ str2lbs $ _CONTENT_LENGTH ++ (show (B.length str))+  B.hPut hdl $ str2lbs _TWO_CRLF+  B.hPut hdl str+  S.hFlush hdl