haskell-debug-adapter-0.0.42.0: src/Haskell/Debug/Adapter/State/Init/Launch.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Haskell.Debug.Adapter.State.Init.Launch where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.State
import Control.Concurrent
import Control.Lens
import Text.Parsec
import qualified Text.Read as R
import qualified System.Log.Logger as L
import qualified Data.ByteString.Lazy as LB
import qualified Data.List as L
import qualified Data.Version as V
import qualified System.Directory as D
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
import qualified HIE.Bios as HIE
import qualified HIE.Bios.Types as HIE
import qualified HIE.Bios.Environment as HIE
-- |
-- Any errors should be critical. don't catch anything here.
--
instance StateActivityIF InitStateData DAP.LaunchRequest where
action _ (LaunchRequest 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 = flip catchError errHdl $ do
setUpConfig req
setUpLogger req
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.
flags <- startGHCi req
setPrompt
launchCmd req
setMainArgs
loadStarupFile flags
-- 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
where
-- |
--
errHdl :: String -> AppContext (Maybe StateTransit)
errHdl msg = do
liftIO $ L.errorM _LOG_APP msg
resSeq <- U.getIncreasedResponseSequence
let res = DAP.defaultLaunchResponse {
DAP.seqLaunchResponse = resSeq
, DAP.request_seqLaunchResponse = DAP.seqLaunchRequest req
, DAP.successLaunchResponse = False
, DAP.messageLaunchResponse = msg
}
U.addResponse $ LaunchResponse res
return Nothing
-- |
--
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
-- | Starts GHCi and returns the list of arguments it passed to invoke it.
startGHCi :: DAP.LaunchRequest -> AppContext [String]
startGHCi req = do
let args = DAP.argumentsLaunchRequest req
initPmpt = maybe _GHCI_PROMPT id (DAP.ghciInitialPromptLaunchRequestArguments args)
envs = DAP.ghciEnvLaunchRequestArguments args
-- Ignore ghciCmd LaunchRequestArguments
-- Instead, use `hie-bios` to do the Right Thing across projects without complicated user input.
-- Eventually, get rid of this option from haskell-dap.
cmdStr = DAP.ghciCmdLaunchRequestArguments args
(cmd:cmdOpts) = filter (not.null) $ U.split " " cmdStr
startup_file = DAP.startupLaunchRequestArguments args
appStores <- get
cwd <- U.liftIOE $ readMVar $ appStores^.workspaceAppStores
-- Use hie-bios when Cmd is exactly "ghci-dap"
flags <- if cmdStr /= "ghci-dap" then addWithGHC cmdOpts else do
isExist <- U.liftIOE $ D.doesFileExist startup_file
when (False == isExist) $ do
U.sendErrorEventLF $ "file not found. [" ++ startup_file ++ "]"
-- throwError $ "file not found. [" ++ startup_file ++ "]"
explicitCradle <- U.liftIOE $ HIE.findCradle startup_file
cradle <- U.liftIOE $ maybe (HIE.loadImplicitCradle mempty startup_file)
(HIE.loadCradle mempty) explicitCradle
libdir <- U.liftIOE (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"
-- getCompilerOptions depends on CWD being the proper root dir.
let compilerOpts = D.withCurrentDirectory cwd $
#if MIN_VERSION_hie_bios(0,14,0)
HIE.getCompilerOptions startup_file HIE.LoadFile cradle
#else
HIE.getCompilerOptions startup_file [] cradle
#endif
HIE.ComponentOptions {HIE.componentOptions = flags} <- U.liftIOE compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"
return $
#if __GLASGOW_HASKELL__ >= 913
-- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading
["-fwrite-if-simplified-core"] ++
#endif
["--interactive", "-B"++libdir] ++ flags
U.debugEV _LOG_APP $ show flags
U.liftIOE $ L.debugM _LOG_APP $ "ghci initial prompt [" ++ initPmpt ++ "]."
U.sendConsoleEventLF $ "CWD: " ++ cwd
U.sendConsoleEventLF $ "CMD: " ++ L.intercalate " " (cmd:flags)
U.sendConsoleEventLF ""
P.startGHCi cmd flags cwd envs
U.sendErrorEventLF $ "Now, waiting for an initial prompt(\""++initPmpt++"\")" ++ " from ghci."
U.sendConsoleEventLF ""
res <- P.expectInitPmpt initPmpt
updateGHCiVersion res
return flags
where
unwrapCradleResult m = \case
HIE.CradleNone -> panic (error m) "HIE.CradleNone"
HIE.CradleFail err -> panic (error m) (unlines $ HIE.cradleErrorStderr err)
HIE.CradleSuccess x -> return x
panic exit m = do
U.sendErrorEvent m
exit
updateGHCiVersion acc = case parse verParser "getGHCiVersion" (unlines acc) of
Right v -> do
U.debugEV _LOG_APP $ "GHCi version is " ++ V.showVersion 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
mver <- view ghciVerAppStores <$> get
U.liftIOE $ putMVar mver v
-- |
--
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.command cmd
P.expectPmpt
P.command cmd2
P.expectPmpt
return ()
-- |
--
launchCmd :: DAP.LaunchRequest -> AppContext ()
launchCmd req = do
let args = DAP.argumentsLaunchRequest req
dap = ":dap-launch "
cmd = dap ++ U.showDAP args
dbg = dap ++ show args
P.command cmd
U.debugEV _LOG_APP dbg
P.expectPmpt
return ()
-- |
--
setMainArgs :: AppContext ()
setMainArgs = view mainArgsAppStores <$> get >>= \case
[] -> return ()
args -> do
let cmd = ":set args "++args
P.command cmd
P.expectPmpt
return ()
-- | Takes as an argument the list of flags used to invoke GHCi to determine
-- if the main module has already been loaded. If it hasn't, loads the main file.
loadStarupFile :: [String] -> AppContext ()
loadStarupFile flags = do
file <- view startupAppStores <$> get
when (not $ any (\lf -> lf `L.isSuffixOf` file) flags) $
-- We only load the file if it hasn't already been given as an argument;
-- Otherwise, we'll force loading the main module and all of its dependencies a second time.
-- That is incredibly painful in large projects (like GHC).
SU.loadHsFile file
let cmd = ":dap-context-modules "
P.command cmd
P.expectPmpt
return ()
addWithGHC :: [String] -> AppContext [String]
addWithGHC [] = return []
addWithGHC cmds
| L.elem "--with-ghc=haskell-dap" cmds = do
U.infoEV _LOG_APP "can not use haskell-dap. deleting \"--with-ghc=haskell-dap\""
addWithGHC $ L.delete "--with-ghc=haskell-dap" cmds
| withGhciExists cmds = return cmds
| "ghci" == head cmds = do
U.infoEV _LOG_APP "\"--with-ghc\" option not found. adding \"--with-ghc=ghci-dap\""
return $ head cmds:"--with-ghc=ghci-dap":tail cmds
| otherwise = return cmds
where
withGhciExists [] = False
withGhciExists (x:xs)
| L.isPrefixOf "--with-ghc=" x = True
| otherwise = withGhciExists xs
-- |
--
_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 \""
, " }"
, " ]"
, "}"
]