diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,7 @@ +20200209 haskell-debug-adapter-0.0.33.0 + * [INFO] support ghci-dap-0.0.14.0. + + 20200105 haskell-debug-adapter-0.0.32.0 * [INFO] support haskell-dap-0.0.14.0. * [INFO] support ghci-dap-0.0.13.0. diff --git a/app/Haskell/Debug/Adapter/Argument.hs b/app/Haskell/Debug/Adapter/Argument.hs deleted file mode 100644 --- a/app/Haskell/Debug/Adapter/Argument.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# 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" - , "" - ] - diff --git a/app/Haskell/Debug/Adapter/Main.hs b/app/Haskell/Debug/Adapter/Main.hs deleted file mode 100644 --- a/app/Haskell/Debug/Adapter/Main.hs +++ /dev/null @@ -1,30 +0,0 @@ -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 - , "--------------------------------------------------------------------------------" - ] - diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,17 +1,71 @@ module Main where import System.Exit -import qualified Haskell.Debug.Adapter.Main as M +import System.IO +import Control.Exception.Safe +import Data.Default +import Options.Applicative +import Paths_haskell_debug_adapter (version) +import Data.Version (showVersion) -import qualified Haskell.Debug.Adapter.Argument as A -import qualified System.Console.CmdArgs as CMD +import Haskell.Debug.Adapter.Control + -- | -- Main -- main :: IO () -main = CMD.cmdArgs A.setting >>= M.run >>= \case - 0 -> exitSuccess - c -> exitWith . ExitFailure $ c +main = getArgs >>= \args -> do + flip catchAny exception + $ flip finally finalize + $ run args stdin stdout + where + finalize = return () + exception e = print e >> exitFailure + + +------------------------------------------------------------------------------- +-- | +-- optparse-applicative +-- +getArgs :: IO ArgData +getArgs = execParser parseInfo + +-- | +-- +parseInfo :: ParserInfo ArgData +parseInfo = info options $ mconcat + [ fullDesc + , header "" + , footer "" + , progDesc "Please see README.md" + ] + +-- | +-- +options :: Parser ArgData +options = (<*>) helper + $ def + <$> verOption + <*> hackageOption + +-- | +-- +verOption :: Parser (a -> a) +verOption = infoOption msg $ mconcat + [ short 'v' + , long "version" + , help "Show version" + ] + where + msg = "haskell-debug-adapter-" ++ showVersion version + +-- | +-- +hackageOption :: Parser (Maybe String) +hackageOption = optional $ strOption $ mconcat + [ long "hackage-version" + , help "hackage version" + ] diff --git a/haskell-debug-adapter.cabal b/haskell-debug-adapter.cabal --- a/haskell-debug-adapter.cabal +++ b/haskell-debug-adapter.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 68d1bb0d01048b286f46f92073a82bbfcd7882495077f4853d74f88246cdf8c2 +-- hash: da77e0a33d754f6f5d7c7f1c43908127b950c2399a352febb7a7d8203d324a5d name: haskell-debug-adapter -version: 0.0.32.0 +version: 0.0.33.0 synopsis: Haskell Debug Adapter. description: Please see README.md category: Development @@ -68,7 +68,6 @@ , base >=4.7 && <5 , bytestring , clock - , cmdargs , conduit , conduit-extra , containers @@ -76,11 +75,12 @@ , directory , filepath , fsnotify - , ghci-dap >=0.0.13.0 + , ghci-dap >=0.0.14.0 , haskell-dap >=0.0.14.0 , hslogger , lens , mtl + , optparse-applicative , parsec , process , resourcet @@ -93,8 +93,6 @@ 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 @@ -107,7 +105,6 @@ , base >=4.7 && <5 , bytestring , clock - , cmdargs , conduit , conduit-extra , containers @@ -115,12 +112,13 @@ , directory , filepath , fsnotify - , ghci-dap >=0.0.13.0 + , ghci-dap >=0.0.14.0 , haskell-dap >=0.0.14.0 , haskell-debug-adapter , hslogger , lens , mtl + , optparse-applicative , parsec , process , resourcet @@ -148,7 +146,6 @@ , base >=4.7 && <5 , bytestring , clock - , cmdargs , conduit , conduit-extra , containers @@ -156,13 +153,14 @@ , directory , filepath , fsnotify - , ghci-dap >=0.0.13.0 + , ghci-dap >=0.0.14.0 , haskell-dap >=0.0.14.0 , haskell-debug-adapter , hslogger , hspec , lens , mtl + , optparse-applicative , parsec , process , resourcet diff --git a/src/Haskell/Debug/Adapter/Control.hs b/src/Haskell/Debug/Adapter/Control.hs --- a/src/Haskell/Debug/Adapter/Control.hs +++ b/src/Haskell/Debug/Adapter/Control.hs @@ -1,63 +1,60 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module Haskell.Debug.Adapter.Control where +module Haskell.Debug.Adapter.Control ( + ArgData(..) + , run + ) 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.Type 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. +-- Start HDA. +-- Default implementation is using STDIN/STDOUT handle. -- -instance Default ArgData where - def = ArgData { - _hackageVersionArgData = "" - } - - --- | --- start running HDA. +-- Here is an example for using TCP Socket. -- -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. +-- > import Network.Socket +-- > +-- > sock <- socket AF_INET Stream defaultProtocol +-- > let host = tupleToHostAddress (0, 0, 0, 0) +-- > port = 9999 +-- > reqQ = 5 +-- > +-- > bind sock $ SockAddrInet port host +-- > listen sock reqQ +-- > +-- > (conn, _) <- accept sock +-- > hdl <- socketToHandle conn ReadWriteMode +-- > +-- > run def hdl hdl +-- > +-- +-- Port 9999 could be specified in the launch.json with "debugServer" attribute. +-- +-- > "debugServer : 9999" +-- +run :: ArgData -- ^command line arguments. + -> Handle -- ^IN handle. used to get request from the debug adapter client. + -> Handle -- ^OUT handle. used to response to the debug adapter client. + -> IO () run _ inHdl outHdl = E.bracket initialize finalize go where -- | - -- + -- initialize = do L.debugM _LOG_NAME $ "initialize called." @@ -76,19 +73,18 @@ 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 + RQ.run appData -- request handler + , A.run appData -- main app + , RP.run appData -- response handler + , W.run appData -- file watch ] TD.start appData ths >>= wait - return 0 diff --git a/src/Haskell/Debug/Adapter/GHCi.hs b/src/Haskell/Debug/Adapter/GHCi.hs --- a/src/Haskell/Debug/Adapter/GHCi.hs +++ b/src/Haskell/Debug/Adapter/GHCi.hs @@ -88,7 +88,7 @@ getReadHandleEncoding :: IO TextEncoding getReadHandleEncoding = if | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" - | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" + | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" -- | -- @@ -125,20 +125,30 @@ proc <- U.liftIOE $ readMVar mvar let hdl = proc^.rHdlGHCiProc - xs <- go pmpt hdl "" - - let strs = map U.rstrip $ lines xs - pout strs - return strs + go pmpt hdl "" >>= \case + Right xs -> do + let strs = map U.rstrip $ lines xs + pout strs + return strs + Left xs -> do + let strs = map U.rstrip $ lines xs + pout strs + throwError "[CRITICAL] can not get the initial ghci prompt." where - go key hdl acc = U.readChar hdl - >>= byPmpt key hdl acc + go :: String -> S.Handle -> String -> AppContext (Either String String) + go key hdl acc = catchError + (U.readChar hdl >>= byPmpt key hdl acc) + (errHdl acc) + errHdl :: String -> String -> AppContext (Either String String) + errHdl acc e = return $ Left $ unlines [acc, "", e, ""] + + byPmpt :: String -> S.Handle -> String -> String -> AppContext (Either String String) byPmpt key hdl acc b = do let newAcc = acc ++ b if L.isSuffixOf key newAcc - then return newAcc + then return $ Right newAcc else go key hdl newAcc pout [] = return () diff --git a/src/Haskell/Debug/Adapter/State/Init/Launch.hs b/src/Haskell/Debug/Adapter/State/Init/Launch.hs --- a/src/Haskell/Debug/Adapter/State/Init/Launch.hs +++ b/src/Haskell/Debug/Adapter/State/Init/Launch.hs @@ -193,6 +193,8 @@ U.sendConsoleEventLF "" P.startGHCi cmd opts cwd envs + U.sendErrorEventLF $ "Now, waiting for an initial prompt(\""++initPmpt++"\")" ++ " from ghci." + U.sendConsoleEventLF "" res <- P.expectInitPmpt initPmpt updateGHCiVersion res diff --git a/src/Haskell/Debug/Adapter/Type.hs b/src/Haskell/Debug/Adapter/Type.hs --- a/src/Haskell/Debug/Adapter/Type.hs +++ b/src/Haskell/Debug/Adapter/Type.hs @@ -6,6 +6,7 @@ module Haskell.Debug.Adapter.Type where +import Data.Data import Data.Default import Control.Lens import Data.Aeson @@ -24,7 +25,34 @@ import Haskell.Debug.Adapter.TH.Utility import Haskell.Debug.Adapter.Constant + -------------------------------------------------------------------------------- +-- | Command Line Argument Data Type. +-- +data ArgData = ArgData { + _hackageVersionArgData :: Maybe String -- ^deprecated. + } deriving (Data, Typeable, Show, Read, Eq) + +makeLenses ''ArgData +$(deriveJSON + defaultOptions { + fieldLabelModifier = fieldModifier "ArgData" + } + ''ArgData) + + +-- | +-- default value instance. +-- +instance Default ArgData where + def = ArgData { + _hackageVersionArgData = Nothing + } + + +-------------------------------------------------------------------------------- +-- | +-- instance FromJSON L.Priority where parseJSON (String v) = pure $ read $ T.unpack v parseJSON o = error $ "json parse error. Priority:" ++ show o diff --git a/test/Haskell/Debug/Adapter/ControlSpec.hs b/test/Haskell/Debug/Adapter/ControlSpec.hs --- a/test/Haskell/Debug/Adapter/ControlSpec.hs +++ b/test/Haskell/Debug/Adapter/ControlSpec.hs @@ -4,7 +4,6 @@ import Test.Hspec import Data.Aeson -import Data.Default import Control.Concurrent (threadDelay) import qualified System.IO as S import Control.Concurrent.Async @@ -26,7 +25,7 @@ $ spec' where - + beforeAll' :: IO () beforeAll' = do return () @@ -40,22 +39,21 @@ after' :: IO () after' = return () - + spec' :: Spec spec' = do describe "run" $ do - context "when default args" $ - xit "should be 0" $ do - let arg = def + context "ok" $ + xit "should be ()" $ do (fromClient, toClient) <- createPipe (fromServer, toServer) <- createPipe (res, _) <- runConcurrently $ (,) - <$> Concurrently (run arg fromClient toClient) + <$> Concurrently (run fromClient toClient) <*> Concurrently (client toServer) - res `shouldBe` 0 + res `shouldBe` () S.hClose fromClient S.hClose toClient