<commit_before>{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}

module DebuggerImpl where

import GHC hiding (resume, back, forward)
import qualified GHC (resume, back, forward)
import GHC.Paths ( libdir )
import DynFlags
import GhcMonad (liftIO)

import ParserMonad (parse)
import CommandParser (debugCommand, DebugCommand(..))
import CmdArgsParser (cmdArgument, Argument(..))
import DebuggerMonad

import Network.Socket
import Network.BSD

import System.IO
import System.Environment (getArgs)
import Control.Monad (mplus, liftM)
import Data.List (partition, sortBy)
import BreakArray
import Data.Array
import Data.Function (on)
import SrcLoc (realSrcSpanEnd)

import Control.Exception (SomeException, throwIO)

import Data.Maybe
import DebuggerUtils

import Debugger (pprintClosureCommand)

import PprTyThing

---- || Debugger runner || --------------------------------------------------------------------------

tryRun :: DebuggerMonad (Result, Bool) -> DebuggerMonad (Result, Bool)
tryRun func = func `gcatch`
    (\ex -> return ([
            ("info", ConsStr "exception"),
            ("message", ConsStr $ show (ex::SomeException))
        ], False))


-- |Runs Ghc program with default settings
defaultRunGhc :: DebuggerMonad a -> IO ()
defaultRunGhc program = defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $
    startDebugger (do
        handleArguments
        st <- getDebugState
        modulePath <- do
            case (mainFile st) of
                Just path -> return path
                Nothing   -> printJSON [
                        ("info", ConsStr "warning"),
                        ("message", ConsStr $ "Main module not specified, choosing " ++ mainModulePath)
                    ] >> return mainModulePath
        setupContext modulePath mainModuleName
        initDebugOutput
        initInterpBuffering
        turnOffBuffering -- turns off buffering of stdout and stderr of program
        program
        return ()
    ) initState

-- |Setup needed flags before running debug program
setupContext :: String -> String -> DebuggerMonad ()
setupContext pathToModule nameOfModule = do
    dflags <- getSessionDynFlags
    setSessionDynFlags $ dflags { hscTarget = HscInterpreted
                                , ghcLink   = LinkInMemory
                                , ghcMode   = CompManager
                                }
    setTargets =<< sequence [guessTarget pathToModule Nothing]
    GHC.load LoadAllTargets
    setContext [IIModule $ mkModuleName nameOfModule]

handleArguments :: DebuggerMonad ()
handleArguments = do
    args <- liftIO getArgs
    mapM_ handle' args where
        handle' x = do
            let arg = fst $ head $ parse cmdArgument x
            case arg of
                Main m    -> modifyDebugState $ \st -> st{mainFile = Just m}
                Import _  -> return ()
                SetPort p -> modifyDebugState $ \st -> st{port = Just p}
                CmdArgsParser.Unknown s -> printJSON [
                        ("info", ConsStr "warning"),
                        ("message", ConsStr $ "unknown argument: " ++ s)
                    ]

initDebugOutput :: DebuggerMonad ()
initDebugOutput = do
    st <- getDebugState
    let m_port = port st
    case m_port of
        Nothing -> printJSON [
                ("info", ConsStr "warning"),
                ("message", ConsStr "Port for debug stream was not set (using stdout); use command line argument -p<port> to set it")
            ]
        Just port' -> do
            let host = "localhost"
            sock <- liftIO $ socket AF_INET Stream 0
            addrs <- liftIO $ liftM hostAddresses $ getHostByName host
            do {
                liftIO $ connect sock $ SockAddrInet (toEnum port') (head addrs);
                handle <- liftIO $ socketToHandle sock ReadWriteMode;
                modifyDebugState $ \st' -> st'{debugOutput = handle};
                printJSON [
                        ("info", ConsStr "connected to port"),
                        ("port", ConsInt port')
                    ];
            } `gcatch` (\ex -> printJSON [
                        ("info", ConsStr "exception"),
                        ("message", ConsStr $ show (ex::SomeException) ++ "; using stdout for debug output")
                    ])

-- |In loop waits for commands and executes them
startCommandLine :: DebuggerMonad ()
startCommandLine = whileNot $ do
    command <- getCommand stdin
    result <- tryRun (runCommand command)
    printJSON $ fst result
    return $ snd result

whileNot :: DebuggerMonad Bool -> DebuggerMonad ()
whileNot p = do
    x <- p
    if not x then whileNot p else return ()

-- |Translates line from input stream into DebugCommand
getCommand :: Handle -> DebuggerMonad DebugCommand
getCommand handle_ = do
    line <- liftIO $ hGetLine handle_
    return $ fst $ head $ parse debugCommand line

type Result = [(String, T)]

-- |Runs DebugCommand and returns True iff debug is finished
-- Inside commands there should not be any output to debug stream
runCommand :: DebugCommand -> DebuggerMonad (Result, Bool)
runCommand (SetBreakpoint modName line)   = notEnd $ setBreakpointLikeGHCiDo modName line
runCommand (SetBreakByIndex modName ind)  = notEnd $ doBreakindex modName ind
runCommand (RemoveBreakpoint modName ind) = notEnd $ deleteBreakpoint modName ind
runCommand (Trace command)                = doTrace command
runCommand Resume                         = doResume
runCommand StepInto                       = doStepInto
runCommand StepOver                       = doStepLocal
runCommand History                        = notEnd $ showHistory defaultHistSize
runCommand Back                           = notEnd $ back
runCommand Forward                        = notEnd $ forward
runCommand Exit                           = return ([], True)
runCommand (BreakList modName)            = notEnd $ showBreaks modName
runCommand (LineBreakList modName line)   = notEnd $ showBreaksForLine modName line
runCommand Help                           = printString fullHelpText >> return ([], False) -- todo: return string as Result
runCommand (SPrint name)                  = notEnd $ doSPrint name
runCommand (Force expr)                   = notEnd $ doForce expr
runCommand (ExprType expr)                = notEnd $ getExprType expr
runCommand (Evaluate force expr)          = notEnd $ evaluate force expr
runCommand (Set flag)                     = notEnd $ set flag
runCommand (Unset flag)                   = notEnd $ unset flag
runCommand _                              = return ([
                                                ("info", ConsStr "exception"),
                                                ("message", ConsStr "unknown command")
                                            ], False)

notEnd :: DebuggerMonad Result -> DebuggerMonad (Result, Bool)
notEnd obj = obj >>= (\x -> return (x, False))

-- | setBreakpoint version with selector just taking first of avaliable breakpoints
setBreakpointFirstOfAvailable :: String -> Int -> DebuggerMonad Result
setBreakpointFirstOfAvailable modName line = setBreakpoint modName line (Just . head)

-- | setBreakpoint version with selector choosing
-- |   - the leftmost complete subexpression on the specified line, or<commit_msg>sources directory command line argument was added<commit_after>{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}

module DebuggerImpl where

import GHC hiding (resume, back, forward)
import qualified GHC (resume, back, forward)
import GHC.Paths ( libdir )
import DynFlags
import GhcMonad (liftIO)

import ParserMonad (parse)
import CommandParser (debugCommand, DebugCommand(..))
import CmdArgsParser (cmdArgument, Argument(..))
import DebuggerMonad

import Network.Socket
import Network.BSD

import System.IO
import System.Environment (getArgs)
import Control.Monad (mplus, liftM)
import Data.List (partition, sortBy)
import BreakArray
import Data.Array
import Data.Function (on)
import SrcLoc (realSrcSpanEnd)

import Control.Exception (SomeException, throwIO)

import Data.Maybe
import DebuggerUtils

import Debugger ()

import PprTyThing

---- || Debugger runner || --------------------------------------------------------------------------

tryRun :: DebuggerMonad (Result, Bool) -> DebuggerMonad (Result, Bool)
tryRun func = func `gcatch`
    (\ex -> return ([
            ("info", ConsStr "exception"),
            ("message", ConsStr $ show (ex::SomeException))
        ], False))


-- |Runs Ghc program with default settings
defaultRunGhc :: DebuggerMonad a -> IO ()
defaultRunGhc program = defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $
    startDebugger (do
        handleArguments
        st <- getDebugState
        modulePath <- do
            case (mainFile st) of
                Just path -> return path
                Nothing   -> printJSON [
                        ("info", ConsStr "warning"),
                        ("message", ConsStr $ "Main module not specified, choosing " ++ mainModulePath)
                    ] >> return mainModulePath
        setupContext modulePath mainModuleName
        initDebugOutput
        initInterpBuffering
        turnOffBuffering -- turns off buffering of stdout and stderr of program
        program
        return ()
    ) initState

-- |Setup needed flags before running debug program
setupContext :: String -> String -> DebuggerMonad ()
setupContext pathToModule nameOfModule = do
    dflags <- getSessionDynFlags
    setSessionDynFlags $ dflags { hscTarget = HscInterpreted
                                , ghcLink   = LinkInMemory
                                , ghcMode   = CompManager
                                }
    setTargets =<< sequence [guessTarget pathToModule Nothing]
    GHC.load LoadAllTargets
    setContext [IIModule $ mkModuleName nameOfModule]

handleArguments :: DebuggerMonad ()
handleArguments = do
    args <- liftIO getArgs
    mapM_ handle' args where
        handle' x = do
            let arg = fst $ head $ parse cmdArgument x
            case arg of
                Main m    -> modifyDebugState $ \st -> st{mainFile = Just m}
                Import path -> do
                    dflags <- getSessionDynFlags
                    setSessionDynFlags dflags{importPaths = path : importPaths dflags}
                    return ()
                SetPort p -> modifyDebugState $ \st -> st{port = Just p}
                CmdArgsParser.Unknown s -> printJSON [
                        ("info", ConsStr "warning"),
                        ("message", ConsStr $ "unknown argument: " ++ s)
                    ]

initDebugOutput :: DebuggerMonad ()
initDebugOutput = do
    st <- getDebugState
    let m_port = port st
    case m_port of
        Nothing -> printJSON [
                ("info", ConsStr "warning"),
                ("message", ConsStr "Port for debug stream was not set (using stdout); use command line argument -p<port> to set it")
            ]
        Just port' -> do
            let host = "localhost"
            sock <- liftIO $ socket AF_INET Stream 0
            addrs <- liftIO $ liftM hostAddresses $ getHostByName host
            do {
                liftIO $ connect sock $ SockAddrInet (toEnum port') (head addrs);
                handle <- liftIO $ socketToHandle sock ReadWriteMode;
                modifyDebugState $ \st' -> st'{debugOutput = handle};
                printJSON [
                        ("info", ConsStr "connected to port"),
                        ("port", ConsInt port')
                    ];
            } `gcatch` (\ex -> printJSON [
                        ("info", ConsStr "exception"),
                        ("message", ConsStr $ show (ex::SomeException) ++ "; using stdout for debug output")
                    ])

-- |In loop waits for commands and executes them
startCommandLine :: DebuggerMonad ()
startCommandLine = whileNot $ do
    command <- getCommand stdin
    result <- tryRun (runCommand command)
    printJSON $ fst result
    return $ snd result

whileNot :: DebuggerMonad Bool -> DebuggerMonad ()
whileNot p = do
    x <- p
    if not x then whileNot p else return ()

-- |Translates line from input stream into DebugCommand
getCommand :: Handle -> DebuggerMonad DebugCommand
getCommand handle_ = do
    line <- liftIO $ hGetLine handle_
    return $ fst $ head $ parse debugCommand line

type Result = [(String, T)]

-- |Runs DebugCommand and returns True iff debug is finished
-- Inside commands there should not be any output to debug stream
runCommand :: DebugCommand -> DebuggerMonad (Result, Bool)
runCommand (SetBreakpoint modName line)   = notEnd $ setBreakpointLikeGHCiDo modName line
runCommand (SetBreakByIndex modName ind)  = notEnd $ doBreakindex modName ind
runCommand (RemoveBreakpoint modName ind) = notEnd $ deleteBreakpoint modName ind
runCommand (Trace command)                = doTrace command
runCommand Resume                         = doResume
runCommand StepInto                       = doStepInto
runCommand StepOver                       = doStepLocal
runCommand History                        = notEnd $ showHistory defaultHistSize
runCommand Back                           = notEnd $ back
runCommand Forward                        = notEnd $ forward
runCommand Exit                           = return ([], True)
runCommand (BreakList modName)            = notEnd $ showBreaks modName
runCommand (LineBreakList modName line)   = notEnd $ showBreaksForLine modName line
runCommand Help                           = printString fullHelpText >> return ([], False)
runCommand (SPrint name)                  = notEnd $ doSPrint name
runCommand (Force expr)                   = notEnd $ doForce expr
runCommand (ExprType expr)                = notEnd $ getExprType expr
runCommand (Evaluate force expr)          = notEnd $ evaluate force expr
runCommand (Set flag)                     = notEnd $ set flag
runCommand (Unset flag)                   = notEnd $ unset flag
runCommand _                              = return ([
                                                ("info", ConsStr "exception"),
                                                ("message", ConsStr "unknown command")
                                            ], False)

notEnd :: DebuggerMonad Result -> DebuggerMonad (Result, Bool)
notEnd obj = obj >>= (\x -> return (x, False))

-- | setBreakpoint version with selector just taking first of avaliable breakpoints
setBreakpointFirstOfAvailable :: String -> Int -> DebuggerMonad Result
setBreakpointFirstOfAvailable modName line = setBreakpoint modName line (Just . head)

-- | setBreakpoint version with selector choosing
-- |   - the leftmost complete subexpression on the specified line, or
{'fraction_non_alphanumeric': 0.08877372459281195, 'fraction_numerical': 0.00013460761879122358, 'mean_word_length': 2.0461254612546127, 'pattern_counts': {'":': 0, '<': 34, '<?xml version=': 0, '>': 65, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 16, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6136879', 'n_tokens_mistral': 3784, 'n_tokens_neox': 3644, 'n_words': 1270}